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;
use URI::QueryParam;
+use Scalar::Util ();
# input position and length
-__PACKAGE__->mk_accessors(qw/read_position read_length/);
+has read_length => (is => 'rw');
+has read_position => (is => 'rw');
+
+has _prepared_write => (is => 'rw');
-# Stringify to class
-use overload '""' => sub { return ref shift }, fallback => 1;
+no Moose;
# Amount of data to read from input on each pass
-our $CHUNKSIZE = 4096;
+our $CHUNKSIZE = 64 * 1024;
=head1 NAME
sub finalize_body {
my ( $self, $c ) = @_;
my $body = $c->response->body;
- if ( ref $body && ($body->can('read') || ref($body) eq 'GLOB') ) {
+ 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 );
=head2 $self->finalize_cookies($c)
-Create CGI::Cookies from $c->res->cookies, and set them as response headers.
+Create CGI::Simple::Cookie objects from $c->res->cookies, and set them as
+response headers.
=cut
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 = (
+ 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;
}
for my $cookie (@cookies) {
- $c->res->headers->push_header( 'Set-Cookie' => $cookie );
+ $response->headers->push_header( 'Set-Cookie' => $cookie );
}
}
=head2 $self->finalize_error($c)
-Output an apropriate error message, called if there's an error in $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.
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 {
'<p><code class="error">'
. encode_entities($_)
$name = "<h1>$name</h1>";
# Don't show context in the dump
- delete $c->req->{_context};
- delete $c->res->{_context};
+ $c->req->_clear_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;
-
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;
<h2><a href="#" onclick="toggleDump('dump_$i'); return false">%s</a></h2>
<div id="dump_$i">
$infos = <<"";
<pre>
(en) Please come back later
-(fr)
+(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
</pre>
$name = '';
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;
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;
=cut
-sub finalize_read {
- my ( $self, $c ) = @_;
-
- undef $self->{_prepared_read};
-}
+sub finalize_read { }
=head2 $self->finalize_uploads($c)
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);
- }
+ 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));
}
+
}
=head2 $self->prepare_body($c)
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 );
- $c->request->{_body}->{tmpdir} = $c->config->{uploadtmp} if exists $c->config->{uploadtmp};
- }
-
- if ( $self->read_length > 0 ) {
+ if ( my $length = $self->read_length ) {
+ my $request = $c->request;
+ unless ( $request->{_body} ) {
+ my $type = $request->header('Content-Type');
+ $request->{_body} = HTTP::Body->new( $type, $length );
+ $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 = $self->read_length - $self->read_position;
- if ($remaining > 0) {
+ my $remaining = $length - $self->read_position;
+ if ( $remaining > 0 ) {
$self->finalize_read($c);
- Catalyst::Exception->throw("Wrong Content-Length value: ". $self->read_length);
+ 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)
sub prepare_body_parameters {
my ( $self, $c ) = @_;
+
+ return unless $c->request->{_body};
+
$c->request->body_parameters( $c->request->{_body}->param );
}
=head2 $self->prepare_cookies($c)
-Parse cookies from header. Sets a L<CGI::Cookie> object.
+Parse cookies from header. Sets a L<CGI::Simple::Cookie> object.
=cut
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) } );
}
}
sub prepare_parameters {
my ( $self, $c ) = @_;
+ my $request = $c->request;
+ my $parameters = $request->parameters;
+ my $body_parameters = $request->body_parameters;
+ my $query_parameters = $request->query_parameters;
# 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;
+ foreach my $name (keys %$query_parameters) {
+ my $param = $query_parameters->{$name};
+ $parameters->{$name} = ref $param eq 'ARRAY' ? [ @$param ] : $param;
}
# 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 ] }
+ foreach my $name (keys %$body_parameters) {
+ my $param = $body_parameters->{$name};
+ my @values = ref $param eq 'ARRAY' ? @$param : ($param);
+ if ( my $existing = $parameters->{$name} ) {
+ unshift(@values, (ref $existing eq 'ARRAY' ? @$existing : $existing));
}
- else { $c->request->parameters->{$name} = $param }
+ $parameters->{$name} = @values > 1 ? \@values : $values[0];
}
}
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)
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)
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 $uploads = $request->{_body}->upload;
+ my $parameters = $request->parameters;
+ foreach my $name (keys %$uploads) {
my $files = $uploads->{$name};
- $files = ref $files eq 'ARRAY' ? $files : [$files];
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 $u = Catalyst::Request::Upload->new
+ (
+ size => $upload->{size},
+ type => $headers->content_type,
+ headers => $headers,
+ tempname => $upload->{tempname},
+ filename => $upload->{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;
- $c->request->parameters->{$name} =
- @filenames > 1 ? \@filenames : $filenames[0];
+ # 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];
+ }
}
}
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;
=head2 $self->write($c, $buffer)
-Writes the buffer to the client. Can only be called once for a request.
+Writes the buffer to the client.
=cut
sub write {
my ( $self, $c, $buffer ) = @_;
- unless ( $self->{_prepared_write} ) {
+ unless ( $self->_prepared_write ) {
$self->prepare_write($c);
- $self->{_prepared_write} = 1;
+ $self->_prepared_write(1);
+ }
+
+ return 0 if !defined $buffer;
+
+ 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;
}
=head2 $self->finalize_output
=head1 AUTHORS
-Sebastian Riedel, <sri@cpan.org>
-
-Andy Grundman, <andy@hybridized.org>
+Catalyst Contributors, see Catalyst.pm
=head1 COPYRIGHT