if ( my $location = $c->response->redirect ) {
$c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
$c->response->header( Location => $location );
- $c->response->status(302) if $c->response->status !~ /3\d\d$/;
+ $c->response->status(302) if $c->response->status !~ /^3\d\d$/;
}
if ( $#{ $c->error } >= 0 ) {
package Catalyst::Engine::Apache;
use strict;
-use mod_perl;
-use constant MP2 => $mod_perl::VERSION >= 1.99;
use base 'Catalyst::Engine';
+
use URI;
use URI::http;
=over 4
-=item $c->finalize_headers
-
-=cut
-
-sub finalize_headers {
- my $c = shift;
-
- for my $name ( $c->response->headers->header_field_names ) {
- next if $name =~ /Content-Type/i;
- my @values = $c->response->header($name);
- $c->apache->headers_out->add( $name => $_ ) for @values;
- }
-
- if ( $c->response->header('Set-Cookie') && $c->response->status >= 300 ) {
- my @values = $c->response->header('Set-Cookie');
- $c->apache->err_headers_out->add( 'Set-Cookie' => $_ ) for @values;
- }
-
- $c->apache->status( $c->response->status );
- $c->apache->content_type( $c->response->header('Content-Type') );
-
- unless ( MP2 ) {
- $c->apache->send_http_header;
- }
-
- return 0;
-}
-
=item $c->finalize_output
=cut
sub prepare_parameters {
my $c = shift;
- my %args;
+
foreach my $key ( $c->apache->param ) {
my @values = $c->apache->param($key);
- $args{$key} = @values == 1 ? $values[0] : \@values;
+ $c->req->parameters->{$key} = ( @values == 1 ) ? $values[0] : \@values;
}
- $c->request->parameters( \%args );
}
=item $c->prepare_path
$c->apache( Apache::Request->new($r) );
}
-=item $c->prepare_uploads
-
-=cut
-
-sub prepare_uploads {
- my $c = shift;
- for my $upload ( $c->apache->upload ) {
- $upload = $c->apache->upload($upload) if MP2;
- $c->request->uploads->{ $upload->filename } = {
- fh => $upload->fh,
- size => $upload->size,
- type => $upload->type
- };
- }
-}
-
=item $c->run
=cut
use strict;
use base 'Catalyst::Engine::Apache';
-use Apache ();
-use Apache::Constants qw(:common);
-use Apache::Request ();
-use Apache::Cookie ();
+use Apache ();
+use Apache::Constants ();
+use Apache::Request ();
+use Apache::Cookie ();
-sub handler ($$) { shift->SUPER::handler(@_) }
+Apache::Constants->import(':common');
=head1 NAME
=over 4
+=item $c->finalize_headers
+
+=cut
+
+sub finalize_headers {
+ my $c = shift;
+
+ for my $name ( $c->response->headers->header_field_names ) {
+ next if $name =~ /Content-Type/i;
+ my @values = $c->response->header($name);
+ $c->apache->headers_out->add( $name => $_ ) for @values;
+ }
+
+ if ( $c->response->header('Set-Cookie') && $c->response->status >= 300 ) {
+ my @values = $c->response->header('Set-Cookie');
+ $c->apache->err_headers_out->add( 'Set-Cookie' => $_ ) for @values;
+ }
+
+ $c->apache->status( $c->response->status );
+ $c->apache->content_type( $c->response->header('Content-Type') );
+
+ $c->apache->send_http_header;
+
+ return 0;
+}
+
=item $c->handler
+=cut
+
+sub handler ($$) {
+ shift->SUPER::handler(@_);
+}
+
+=item $c->prepare_uploads
+
+=cut
+
+sub prepare_uploads {
+ my $c = shift;
+
+ my @uploads;
+
+ for my $upload ( $c->apache->upload ) {
+
+ my $hash = {
+ fh => $upload->fh,
+ filename => $upload->filename,
+ size => $upload->size,
+ tempname => $upload->tempname,
+ type => $upload->type
+ };
+
+ push( @uploads, $upload->name, $hash );
+ }
+
+ $c->req->_assign_values( $c->req->uploads, \@uploads );
+}
+
=back
=head1 SEE ALSO
use strict;
use base 'Catalyst::Engine::Apache';
-use Apache2 ();
-use Apache::Connection ();
-use Apache::Const ( -compile => qw(:common) );
-use Apache::RequestIO ();
-use Apache::RequestRec ();
+use Apache2 ();
+use Apache::Connection ();
+use Apache::Const ();
+use Apache::RequestIO ();
+use Apache::RequestRec ();
use Apache::RequestUtil ();
-use Apache::Request ();
-use Apache::Cookie ();
-use Apache::Upload ();
-use Apache::URI ();
-use APR::URI ();
+use Apache::Request ();
+use Apache::Cookie ();
+use Apache::Upload ();
+use Apache::URI ();
+use APR::URI ();
-sub handler : method { shift->SUPER::handler(@_) }
+Apache::Const->import( -compile => ':common' );
=head1 NAME
=over 4
+=item $c->finalize_headers
+
+=cut
+
+sub finalize_headers {
+ my $c = shift;
+
+ for my $name ( $c->response->headers->header_field_names ) {
+ next if $name =~ /Content-Type/i;
+ my @values = $c->response->header($name);
+ $c->apache->headers_out->add( $name => $_ ) for @values;
+ }
+
+ if ( $c->response->header('Set-Cookie') && $c->response->status >= 300 ) {
+ my @values = $c->response->header('Set-Cookie');
+ $c->apache->err_headers_out->add( 'Set-Cookie' => $_ ) for @values;
+ }
+
+ $c->apache->status( $c->response->status );
+ $c->apache->content_type( $c->response->header('Content-Type') );
+
+ return 0;
+}
+
=item $c->handler
+=cut
+
+sub handler : method {
+ shift->SUPER::handler(@_);
+}
+
+=item $c->prepare_uploads
+
+=cut
+
+sub prepare_uploads {
+ my $c = shift;
+
+ my @uploads;
+
+ for my $field ( $c->apache->upload ) {
+
+ for my $upload ( $c->apache->upload($field) ) {
+
+ my $hash = {
+ fh => $upload->fh,
+ filename => $upload->filename,
+ size => $upload->size,
+ tempname => $upload->tempname,
+ type => $upload->type
+ };
+
+ push( @uploads, $field, $hash );
+ }
+ }
+
+ $c->req->_assign_values( $c->req->uploads, \@uploads );
+}
+
=back
=head1 SEE ALSO
use strict;
use base 'Catalyst::Engine';
+
+use CGI;
use URI;
use URI::http;
-require CGI::Simple;
-
-$CGI::Simple::POST_MAX = 1048576;
-$CGI::Simple::DISABLE_UPLOADS = 0;
-
__PACKAGE__->mk_accessors('cgi');
=head1 NAME
=head1 DESCRIPTION
This is the Catalyst engine specialized for the CGI environment (using the
-C<CGI::Simple> and C<CGI::Cookie> modules). Normally Catalyst will select the
+C<CGI> and C<CGI::Cookie> modules). Normally Catalyst will select the
appropriate engine according to the environment that it detects, however you
can force Catalyst to use the CGI engine by specifying the following in your
application module:
=item $c->cgi
-This config parameter contains the C<CGI::Simple> object.
+This config parameter contains the C<CGI> object.
=back
sub finalize_headers {
my $c = shift;
- my %headers;
-
- $headers{-status} = $c->response->status if $c->response->status;
- for my $name ( $c->response->headers->header_field_names ) {
- $headers{"-$name"} = $c->response->header($name);
- }
+ $c->response->header( Status => $c->response->status );
- print $c->cgi->header(%headers);
+ print $c->response->headers->as_string("\015\012");
+ print "\015\012";
}
=item $c->finalize_output
sub prepare_connection {
my $c = shift;
- $c->req->hostname( $c->cgi->remote_host );
- $c->req->address( $c->cgi->remote_addr );
+ $c->req->hostname( $ENV{REMOTE_HOST} );
+ $c->req->address( $ENV{REMOTE_ADDR} );
}
=item $c->prepare_headers
sub prepare_headers {
my $c = shift;
- $c->req->method( $c->cgi->request_method );
- for my $header ( $c->cgi->http ) {
+
+ while ( my ( $header, $value ) = each %ENV ) {
+
+ next unless $header =~ /^(HTTP|CONTENT)/i;
+
( my $field = $header ) =~ s/^HTTPS?_//;
- $c->req->headers->header( $field => $c->cgi->http($header) );
+
+ $c->req->headers->header( $field => $value );
}
- $c->req->headers->header( 'Content-Type' => $c->cgi->content_type );
- $c->req->headers->header( 'Content-Length' => $c->cgi->content_length );
+
+ $c->req->method( $ENV{REQUEST_METHOD} || 'GET' );
}
=item $c->prepare_parameters
=cut
sub prepare_parameters {
- my $c = shift;
-
- $c->cgi->parse_query_string;
-
- my %vars = $c->cgi->Vars;
- while ( my ( $key, $value ) = each %vars ) {
- my @values = split "\0", $value;
- $vars{$key} = @values <= 1 ? $values[0] : \@values;
+ my $c = shift;
+
+ for my $param ( $c->cgi->param ) {
+ my @values = $c->cgi->param($param);
+ $c->req->parameters->{$param} = ( @values > 1 ) ? \@values : $values[0];
}
- $c->req->parameters( {%vars} );
}
=item $c->prepare_path
my $base;
{
my $scheme = $ENV{HTTPS} ? 'https' : 'http';
- my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
+ my $host = $ENV{HTTP_HOST} || $ENV{SERVER_NAME};
my $port = $ENV{SERVER_PORT} || 80;
my $path = $ENV{SCRIPT_NAME} || '/';
my $path = $ENV{PATH_INFO} || '/';
$path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
- $path =~ s/^\///;
+ $path =~ s/^\///;
$c->req->base($base);
$c->req->path($path);
=cut
-sub prepare_request { shift->cgi( CGI::Simple->new ) }
+sub prepare_request {
+ my $c = shift;
+ $c->cgi( CGI->new );
+ $c->cgi->_reset_globals;
+}
=item $c->prepare_uploads
sub prepare_uploads {
my $c = shift;
- for my $name ( $c->cgi->upload ) {
- next unless defined $name;
- $c->req->uploads->{$name} = {
- fh => $c->cgi->upload($name),
- size => $c->cgi->upload_info( $name, 'size' ),
- type => $c->cgi->upload_info( $name, 'mime' )
- };
+
+ my @uploads;
+
+ for my $param ( $c->cgi->param ) {
+
+ my @values = $c->cgi->param($param);
+
+ next unless ref( $values[0] );
+
+ for my $fh (@values) {
+
+ next unless my $size = ( stat $fh )[7];
+
+ my $info = $c->cgi->uploadInfo($fh);
+ my $tempname = $c->cgi->tmpFileName($fh);
+ my $type = $info->{'Content-Type'};
+ my $disposition = $info->{'Content-Disposition'};
+ my $filename = ( $disposition =~ / filename="([^;]*)"/ )[0];
+
+ my $upload = {
+ fh => $fh,
+ filename => $filename,
+ size => $size,
+ tempname => $tempname,
+ type => $type
+ };
+
+ push( @uploads, $param, $upload );
+ }
}
+
+ $c->req->_assign_values( $c->req->uploads, \@uploads );
}
=item $c->run
use HTTP::Headers::Util 'split_header_words';
use HTTP::Request;
use HTTP::Response;
-use IO::File;
+use File::Temp;
use URI;
__PACKAGE__->mk_accessors(qw/http/);
sub prepare_parameters {
my $c = shift;
- my @params = ();
+ my ( @params, @uploads );
+
my $request = $c->http->request;
push( @params, $request->uri->query_form );
if ( $parameters{filename} ) {
- my $fh = IO::File->new_tmpfile;
+ my $fh = File::Temp->new;
$fh->write( $part->content ) or die $!;
- $fh->seek( SEEK_SET, 0 ) or die $!;
-
- $c->req->uploads->{ $parameters{filename} } = {
- fh => $fh,
- size => ( stat $fh )[7],
- type => $part->content_type
+ seek( $fh, 0, 0 ) or die $!;
+
+ my $upload = {
+ fh => $fh,
+ filename => $parameters{filename},
+ size => ( stat $fh )[7],
+ tempname => $fh->filename,
+ type => $part->content_type
};
- push( @params, $parameters{filename}, $fh );
+ push( @uploads, $parameters{name}, $upload );
+ push( @params, $parameters{name}, $fh );
}
else {
push( @params, $parameters{name}, $part->content );
}
}
}
-
- my $parameters = $c->req->parameters;
-
- while ( my ( $name, $value ) = splice( @params, 0, 2 ) ) {
-
- if ( exists $parameters->{$name} ) {
- for ( $parameters->{$name} ) {
- $_ = [$_] unless ref($_) eq "ARRAY";
- push( @$_, $value );
- }
- }
- else {
- $parameters->{$name} = $value;
- }
- }
+
+ $c->req->_assign_values( $c->req->parameters, \@params );
+ $c->req->_assign_values( $c->req->uploads, \@uploads );
}
=item $c->prepare_path
unless ( ref $request ) {
- my $uri = ( $request =~ m/http/i )
+ my $uri =
+ ( $request =~ m/http/i )
? URI->new($request)
: URI->new( 'http://localhost' . $request );
sub referer { shift->headers->referer(@_) }
sub user_agent { shift->headers->user_agent(@_) }
+
+sub _assign_values {
+ my ( $self, $map, $values ) = @_;
+
+ while ( my ( $name, $value ) = splice( @{ $values }, 0, 2 ) ) {
+
+ if ( exists $map->{$name} ) {
+ for ( $map->{$name} ) {
+ $_ = [$_] unless ref($_) eq "ARRAY";
+ push( @$_, $value );
+ }
+ }
+ else {
+ $map->{$name} = $value;
+ }
+ }
+}
+
=head1 NAME
Catalyst::Request - Catalyst Request Class
$req->hostname;
$req->match;
$req->method;
- $req->parameters;
+ $req->param;
$req->params;
+ $req->parameters;
$req->path;
$req->referer;
$req->snippets;
+ $req->upload;
$req->uploads;
$req->user_agent
=item $req->match
-This contains be the matching part of a regexp action. otherwise it
+This contains be the matching part of a regexp action. otherwise it
returns the same as 'action'.
print $c->request->match;
Contains the request method (C<GET>, C<POST>, C<HEAD>, etc).
- print $c->request->method
+ print $c->request->method;
+
+=item $req->param
+
+Get request parameters with a CGI.pm like param method.
+
+ $value = $c->request->param('foo');
+ @values = $c->request->param('foo');
+ @params = $c->request->param;
+
+=cut
+
+sub param {
+ my $self = shift;
+
+ if ( @_ == 0 ) {
+ return keys %{ $self->parameters };
+ }
+
+ my $param = shift;
+
+ unless ( exists $self->parameters->{$param} ) {
+ return wantarray ? () : undef;
+ }
+
+ if ( ref $self->parameters->{$param} eq 'ARRAY' ) {
+ return (wantarray)
+ ? @{ $self->parameters->{$param} }
+ : $self->parameters->{$param}->[0];
+ }
+ else {
+ return (wantarray)
+ ? ( $self->parameters->{$param} )
+ : $self->parameters->{$param};
+ }
+}
=item $req->params
=item $req->parameters
-Returns a reference to a hash containing the parameters.
+Returns a reference to a hash containing parameters. Values can
+be either a scalar or a arrayref containing scalars.
- print $c->request->parameters->{foo};
+ print $c->request->parameters->{field};
+ print $c->request->parameters->{field}->[0];
=item $req->path
my @snippets = @{ $c->request->snippets };
+=item $req->upload
+
+A convenient method to $req->uploads.
+
+ $upload = $c->request->upload('field');
+ @uploads = $c->request->upload('field');
+ @fields = $c->request->upload;
+
+ for my $upload ( $c->request->upload('field') ) {
+ print $upload->{filename};
+ }
+
+=cut
+
+sub upload {
+ my $self = shift;
+
+ if ( @_ == 0 ) {
+ return keys %{ $self->uploads };
+ }
+
+ my $upload = shift;
+
+ unless ( exists $self->uploads->{$upload} ) {
+ return wantarray ? () : undef;
+ }
+
+ if ( ref $self->uploads->{$upload} eq 'ARRAY' ) {
+ return (wantarray)
+ ? @{ $self->uploads->{$upload} }
+ : $self->uploads->{$upload}->[0];
+ }
+ else {
+ return (wantarray)
+ ? ( $self->uploads->{$upload} )
+ : $self->uploads->{$upload};
+ }
+}
+
=item $req->uploads
-Returns a reference to a hash containing the uploads.
+Returns a reference to a hash containing uploads. Values can
+be either a hashref or a arrayref containing hashrefs.
+
+ my $upload = $c->request->uploads->{field};
+ my $upload = $c->request->uploads->{field}->[0];
+
+The upload hashref contains the following keys:
+
+=over 4
+
+=item * fh
+
+Filehandle.
- my $filename = $c->req->parameters->{foo};
- print $c->request->uploads->{$filename}->{type};
- print $c->request->uploads->{$filename}->{size};
- my $fh = $c->request->uploads->{$filename}->{fh};
- my $content = do { local $/; <$fh> };
+=item * filename
+
+Client supplied filename.
+
+=item * size
+
+Size of the file in bytes.
+
+=item * tempname
+
+Path to the temporary spool file.
+
+=item * type
+
+Client supplied Content-Type.
+
+=back
=item $req->user_agent
=head1 COPYRIGHT
-This program is free software, you can redistribute it and/or modify
+This program is free software, you can redistribute it and/or modify
it under the same terms as Perl itself.
=cut
projects / catagits/Catalyst-Runtime.git / commitdiff