X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst%2FEngine.pm;h=18addd4064ddd6dcea52ac2b6f68c439732d286d;hb=e16a6c4e6c4d49e73b5286b3186616af14f3f554;hp=44176bc2d941128224c09e07157ac7a464310aea;hpb=2666dd3ba45edb0fa31508f67d94fe80072f94f6;p=catagits%2FCatalyst-Runtime.git diff --git a/lib/Catalyst/Engine.pm b/lib/Catalyst/Engine.pm index 44176bc..18addd4 100644 --- a/lib/Catalyst/Engine.pm +++ b/lib/Catalyst/Engine.pm @@ -2,12 +2,14 @@ package Catalyst::Engine; use strict; use base 'Class::Accessor::Fast'; -use CGI::Cookie; -use Data::Dumper; +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 Scalar::Util (); # input position and length __PACKAGE__->mk_accessors(qw/read_position read_length/); @@ -16,7 +18,7 @@ __PACKAGE__->mk_accessors(qw/read_position read_length/); use overload '""' => sub { return ref shift }, fallback => 1; # Amount of data to read from input on each pass -our $CHUNKSIZE = 4096; +our $CHUNKSIZE = 64 * 1024; =head1 NAME @@ -30,9 +32,6 @@ See L. =head1 METHODS -=head2 $self->finalize_output - -, see finalize_body =head2 $self->finalize_body($c) @@ -42,35 +41,47 @@ Finalize body. Prints the response output. sub finalize_body { my ( $self, $c ) = @_; - if ( ref $c->response->body && $c->response->body->can('read') ) { - while ( !$c->response->body->eof() ) { - $c->response->body->read( my $buffer, $CHUNKSIZE ); + my $body = $c->response->body; + no warnings 'uninitialized'; + if ( Scalar::Util::blessed($body) && $body->can('read') or ref($body) eq 'GLOB' ) { + while ( !eof $body ) { + read $body, my ($buffer), $CHUNKSIZE; last unless $self->write( $c, $buffer ); } - $c->response->body->close(); + close $body; } else { - $self->write( $c, $c->response->body ); + $self->write( $c, $body ); } } =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; - 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 + + foreach my $name ( keys %{ $c->response->cookies } ) { + + my $val = $c->response->cookies->{$name}; + + my $cookie = ( + Scalar::Util::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 + ) ); push @cookies, $cookie->as_string; @@ -83,19 +94,22 @@ sub finalize_cookies { =head2 $self->finalize_error($c) +Output an apropriate 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 finalize_error { my ( $self, $c ) = @_; $c->res->content_type('text/html; charset=utf-8'); - my $name = $c->config->{name} || 'Catalyst Application'; + my $name = $c->config->{name} || join(' ', split('::', ref $c)); my ( $title, $error, $infos ); if ( $c->debug ) { # For pretty dumps - local $Data::Dumper::Terse = 1; $error = join '', map { '

' . encode_entities($_) @@ -116,15 +130,11 @@ sub finalize_error { # 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; - my @infos; my $i = 0; for my $dump ( $c->dump_these ) { my $name = $dump->[0]; - my $value = encode_entities( Dumper $dump->[1] ); + my $value = encode_entities( dump( $dump->[1] )); push @infos, sprintf <<"EOF", $name, $value;

%s

@@ -141,11 +151,15 @@ EOF $infos = <<""; 
 (en) Please come back later
+(fr) SVP veuillez revenir plus tard
 (de) Bitte versuchen sie es spaeter nocheinmal
 (at) Konnten's bitt'schoen spaeter nochmal reinschauen
 (no) Vennligst prov igjen senere
 (dk) Venligst prov igen senere
 (pl) Prosze sprobowac pozniej
+(pt) Por favor volte mais tarde
+(ru) Попробуйте еще раз позже
+(ua) Спробуйте ще раз пізніше
$name = ''; @@ -175,13 +189,13 @@ EOF body { font-family: "Bitstream Vera Sans", "Trebuchet MS", Verdana, Tahoma, Arial, helvetica, sans-serif; - color: #ddd; + color: #333; background-color: #eee; margin: 0px; padding: 0px; } :link, :link:hover, :visited, :visited:hover { - color: #ddd; + color: #000; } div.box { position: relative; @@ -189,30 +203,26 @@ EOF border: 1px solid #aaa; padding: 4px; margin: 10px; - -moz-border-radius: 10px; } div.error { - background-color: #977; + background-color: #cce; border: 1px solid #755; padding: 8px; margin: 4px; margin-bottom: 10px; - -moz-border-radius: 10px; } div.infos { - background-color: #797; + background-color: #eee; border: 1px solid #575; padding: 8px; margin: 4px; margin-bottom: 10px; - -moz-border-radius: 10px; } div.name { - background-color: #779; + background-color: #cce; border: 1px solid #557; padding: 8px; margin: 4px; - -moz-border-radius: 10px; } code.error { display: block; @@ -263,6 +273,8 @@ EOF =head2 $self->finalize_headers($c) +Abstract method, allows engines to write headers to response + =cut sub finalize_headers { } @@ -271,14 +283,12 @@ sub finalize_headers { } =cut -sub finalize_read { - my ( $self, $c ) = @_; - - undef $self->{_prepared_read}; -} +sub finalize_read { } =head2 $self->finalize_uploads($c) +Clean up after uploads, deleting temp files. + =cut sub finalize_uploads { @@ -296,27 +306,43 @@ sub finalize_uploads { =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 ) { + if ( my $length = $self->read_length ) { + unless ( $c->request->{_body} ) { + my $type = $c->request->header('Content-Type'); + $c->request->{_body} = HTTP::Body->new( $type, $length ); + $c->request->{_body}->tmpdir( $c->config->{uploadtmp} ) + if exists $c->config->{uploadtmp}; + } + while ( my $buffer = $self->read($c) ) { $c->prepare_body_chunk($buffer); } + + # paranoia against wrong Content-Length header + my $remaining = $length - $self->read_position; + if ( $remaining > 0 ) { + $self->finalize_read($c); + Catalyst::Exception->throw( + "Wrong Content-Length value: $length" ); + } + } + else { + # Defined but will cause all body code to be skipped + $c->request->{_body} = 0; } } =head2 $self->prepare_body_chunk($c) +Add a chunk to the request body. + =cut sub prepare_body_chunk { @@ -327,28 +353,37 @@ sub prepare_body_chunk { =head2 $self->prepare_body_parameters($c) +Sets up parameters from body. + =cut sub prepare_body_parameters { my ( $self, $c ) = @_; + + return unless $c->request->{_body}; + $c->request->body_parameters( $c->request->{_body}->param ); } =head2 $self->prepare_connection($c) +Abstract method implemented in engines. + =cut sub prepare_connection { } =head2 $self->prepare_cookies($c) +Parse cookies from header. Sets a L object. + =cut sub prepare_cookies { my ( $self, $c ) = @_; if ( my $header = $c->request->header('Cookie') ) { - $c->req->cookies( { CGI::Cookie->parse($header) } ); + $c->req->cookies( { CGI::Simple::Cookie->parse($header) } ); } } @@ -360,19 +395,23 @@ sub prepare_headers { } =head2 $self->prepare_parameters($c) +sets up parameters from query and post parameters. + =cut sub prepare_parameters { my ( $self, $c ) = @_; # We copy, no references - while ( my ( $name, $param ) = each %{ $c->request->query_parameters } ) { + foreach my $name ( keys %{ $c->request->query_parameters } ) { + my $param = $c->request->query_parameters->{$name}; $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param; $c->request->parameters->{$name} = $param; } # Merge query and body parameters - while ( my ( $name, $param ) = each %{ $c->request->body_parameters } ) { + foreach my $name ( keys %{ $c->request->body_parameters } ) { + my $param = $c->request->body_parameters->{$name}; $param = ref $param eq 'ARRAY' ? [ @{$param} ] : $param; if ( my $old_param = $c->request->parameters->{$name} ) { if ( ref $old_param eq 'ARRAY' ) { @@ -387,6 +426,8 @@ sub prepare_parameters { =head2 $self->prepare_path($c) +abstract method, implemented by engines. + =cut sub prepare_path { } @@ -395,35 +436,71 @@ sub prepare_path { } =head2 $self->prepare_query_parameters($c) +process the query string and extract query parameters. + =cut sub prepare_query_parameters { my ( $self, $c, $query_string ) = @_; + + # Check for keywords (no = signs) + # (yes, index() is faster than a regex :)) + if ( index( $query_string, '=' ) < 0 ) { + $c->request->query_keywords( $self->unescape_uri($query_string) ); + return; + } + + my %query; # replace semi-colons $query_string =~ s/;/&/g; - - my $u = URI->new( '', 'http' ); - $u->query($query_string); - for my $key ( $u->query_param ) { - my @vals = $u->query_param($key); - $c->request->query_parameters->{$key} = @vals > 1 ? [@vals] : $vals[0]; + + my @params = grep { length $_ } split /&/, $query_string; + + for my $item ( @params ) { + + my ($param, $value) + = map { $self->unescape_uri($_) } + split( /=/, $item, 2 ); + + $param = $self->unescape_uri($item) unless defined $param; + + if ( exists $query{$param} ) { + if ( ref $query{$param} ) { + push @{ $query{$param} }, $value; + } + else { + $query{$param} = [ $query{$param}, $value ]; + } + } + else { + $query{$param} = $value; + } } + + $c->request->query_parameters( \%query ); } =head2 $self->prepare_read($c) +prepare to read from the engine. + =cut sub prepare_read { my ( $self, $c ) = @_; - # Reset the read position + # Initialize the read position $self->read_position(0); + + # Initialize the amount of data we think we need to read + $self->read_length( $c->request->header('Content-Length') || 0 ); } =head2 $self->prepare_request(@arguments) +Populate the context object from the request object. + =cut sub prepare_request { } @@ -434,6 +511,9 @@ sub prepare_request { } sub prepare_uploads { my ( $self, $c ) = @_; + + return unless $c->request->{_body}; + my $uploads = $c->request->{_body}->upload; for my $name ( keys %$uploads ) { my $files = $uploads->{$name}; @@ -452,13 +532,27 @@ sub prepare_uploads { # support access to the filename as a normal param my @filenames = map { $_->{filename} } @uploads; - $c->request->parameters->{$name} = - @filenames > 1 ? \@filenames : $filenames[0]; + # append, if there's already params with this name + if (exists $c->request->parameters->{$name}) { + if (ref $c->request->parameters->{$name} eq 'ARRAY') { + push @{ $c->request->parameters->{$name} }, @filenames; + } + else { + $c->request->parameters->{$name} = + [ $c->request->parameters->{$name}, @filenames ]; + } + } + else { + $c->request->parameters->{$name} = + @filenames > 1 ? \@filenames : $filenames[0]; + } } } =head2 $self->prepare_write($c) +Abstract method. Implemented by the engines. + =cut sub prepare_write { } @@ -470,11 +564,6 @@ sub prepare_write { } 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 ||= $CHUNKSIZE; @@ -516,12 +605,16 @@ The amount of input data that has already been read. =head2 $self->run($c) +Start the engine. Implemented by the various engine classes. + =cut sub run { } =head2 $self->write($c, $buffer) +Writes the buffer to the client. + =cut sub write { @@ -531,15 +624,56 @@ sub write { $self->prepare_write($c); $self->{_prepared_write} = 1; } + + my $len = length($buffer); + my $wrote = syswrite STDOUT, $buffer; + + if ( !defined $wrote && $! == EWOULDBLOCK ) { + # Unable to write on the first try, will retry in the loop below + $wrote = 0; + } + + if ( defined $wrote && $wrote < $len ) { + # We didn't write the whole buffer + while (1) { + my $ret = syswrite STDOUT, $buffer, $CHUNKSIZE, $wrote; + if ( defined $ret ) { + $wrote += $ret; + } + else { + next if $! == EWOULDBLOCK; + return; + } + + last if $wrote >= $len; + } + } + + return $wrote; +} + +=head2 $self->unescape_uri($uri) - print STDOUT $buffer; +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 unescape_uri { + my ( $self, $str ) = @_; + + $str =~ s/(?:%([0-9A-Fa-f]{2})|\+)/defined $1 ? chr(hex($1)) : ' '/eg; + + return $str; } -=head1 AUTHORS +=head2 $self->finalize_output + +, see finalize_body -Sebastian Riedel, +=head1 AUTHORS -Andy Grundman, +Catalyst Contributors, see Catalyst.pm =head1 COPYRIGHT