X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst.pm;h=1b73f235b2b96b81d8d4c10906ab387fef79c4a7;hp=571b120cd89ff8d036196637bffa0e761df2016d;hb=0ca510f0aa1cabe138d81897d38111d7b772449c;hpb=6e94698dcf3a2dca78fd6f572c0860a1e386b118 diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm old mode 100755 new mode 100644 index 571b120..1b73f23 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -47,13 +47,14 @@ use Plack::Middleware::HTTPExceptions; use Plack::Middleware::FixMissingBodyInRedirect; use Plack::Middleware::MethodOverride; use Plack::Middleware::RemoveRedundantBody; +use Catalyst::Middleware::Stash; use Plack::Util; use Class::Load 'load_class'; +use Encode 2.21 'decode_utf8', 'encode_utf8'; BEGIN { require 5.008003; } has stack => (is => 'ro', default => sub { [] }); -has stash => (is => 'rw', default => sub { {} }); has state => (is => 'rw', default => 0); has stats => (is => 'rw'); has action => (is => 'rw'); @@ -117,16 +118,17 @@ __PACKAGE__->mk_classdata($_) for qw/components arguments dispatcher engine log dispatcher_class engine_loader context_class request_class response_class stats_class setup_finished _psgi_app loading_psgi_file run_options _psgi_middleware - _data_handlers/; + _data_handlers _encoding _encode_check/; __PACKAGE__->dispatcher_class('Catalyst::Dispatcher'); __PACKAGE__->request_class('Catalyst::Request'); __PACKAGE__->response_class('Catalyst::Response'); __PACKAGE__->stats_class('Catalyst::Stats'); +__PACKAGE__->_encode_check(Encode::FB_CROAK | Encode::LEAVE_SRC); # Remember to update this in Catalyst::Runtime as well! - -our $VERSION = '5.90062'; +our $VERSION = '5.90080_001'; +$VERSION = eval $VERSION if $VERSION =~ /_/; # numify for warning-free dev releases sub import { my ( $class, @arguments ) = @_; @@ -494,23 +496,24 @@ Catalyst). # stash is automatically passed to the view for use in a template $c->forward( 'MyApp::View::TT' ); -=cut +The stash hash is currently stored in the PSGI C<$env> and is managed by +L. Since it's part of the C<$env> items in +the stash can be accessed in sub applications mounted under your main +L application. For example if you delegate the response of an +action to another L application, that sub application will have +access to all the stash keys of the main one, and if can of course add +more keys of its own. However those new keys will not 'bubble' back up +to the main application. -around stash => sub { - my $orig = shift; - my $c = shift; - my $stash = $orig->($c); - if (@_) { - my $new_stash = @_ > 1 ? {@_} : $_[0]; - croak('stash takes a hash or hashref') unless ref $new_stash; - foreach my $key ( keys %$new_stash ) { - $stash->{$key} = $new_stash->{$key}; - } - } +For more information the best thing to do is to review the test case: +t/middleware-stash.t in the distribution /t directory. - return $stash; -}; +=cut +sub stash { + my $c = shift; + return Catalyst::Middleware::Stash::get_stash($c->req->env)->(@_); +} =head2 $c->error @@ -564,6 +567,14 @@ sub clear_errors { $c->error(0); } +=head2 $c->has_errors + +Returns true if you have errors + +=cut + +sub has_errors { scalar(@{shift->error}) ? 1:0 } + sub _comp_search_prefixes { my $c = shift; return map $c->components->{ $_ }, $c->_comp_names_search_prefixes(@_); @@ -1000,6 +1011,38 @@ And later: Your log class should implement the methods described in L. +=head2 encoding + +Sets or gets the application encoding. + +=cut + +sub encoding { + my $c = shift; + my $encoding; + + if ( scalar @_ ) { + # Let it be set to undef + if (my $wanted = shift) { + $encoding = Encode::find_encoding($wanted) + or Carp::croak( qq/Unknown encoding '$wanted'/ ); + binmode(STDERR, ':encoding(' . $encoding->name . ')'); + } + else { + binmode(STDERR); + } + + $encoding = ref $c + ? $c->{encoding} = $encoding + : $c->_encoding($encoding); + } else { + $encoding = ref $c && exists $c->{encoding} + ? $c->{encoding} + : $c->_encoding; + } + + return $encoding; +} =head2 $c->debug @@ -1173,6 +1216,11 @@ EOF $class->setup unless $Catalyst::__AM_RESTARTING; } + # If you are expecting configuration info as part of your setup, it needs + # to get called here and below, since we need the above line to support + # ConfigLoader based configs. + + $class->setup_encoding(); $class->setup_middleware(); # Initialize our data structure @@ -1252,9 +1300,10 @@ EOF } $class->setup_finalize; - # Should be the last thing we do so that user things hooking - # setup_finalize can log.. + + # Flush the log for good measure (in case something turned off 'autoflush' early) $class->log->_flush() if $class->log->can('_flush'); + return $class || 1; # Just in case someone named their Application 0... } @@ -1340,30 +1389,38 @@ sub uri_for { ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} ); carp "uri_for called with undef argument" if grep { ! defined $_ } @args; + + my @encoded_args = (); foreach my $arg (@args) { - utf8::encode($arg) if utf8::is_utf8($arg); - $arg =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; + if(ref($arg)||'' eq 'ARRAY') { + push @encoded_args, [map { + my $encoded = encode_utf8 $_; + $encoded =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; + $encoded; + } @$arg]; + } else { + push @encoded_args, do { + my $encoded = encode_utf8 $arg; + $encoded =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; + $encoded; + } + } } if ( $path->$_isa('Catalyst::Action') ) { # action object - s|/|%2F|g for @args; + s|/|%2F|g for @encoded_args; my $captures = [ map { s|/|%2F|g; $_; } - ( scalar @args && ref $args[0] eq 'ARRAY' - ? @{ shift(@args) } + ( scalar @encoded_args && ref $encoded_args[0] eq 'ARRAY' + ? @{ shift(@encoded_args) } : ()) ]; - foreach my $capture (@$captures) { - utf8::encode($capture) if utf8::is_utf8($capture); - $capture =~ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go; - } - my $action = $path; # ->uri_for( $action, \@captures_and_args, \%query_values? ) - if( !@args && $action->number_of_args ) { + if( !@encoded_args && $action->number_of_args ) { my $expanded_action = $c->dispatcher->expand_action( $action ); my $num_captures = $expanded_action->number_of_captures; - unshift @args, splice @$captures, $num_captures; + unshift @encoded_args, splice @$captures, $num_captures; } $path = $c->dispatcher->uri_for_action($action, $captures); @@ -1375,18 +1432,18 @@ sub uri_for { $path = '/' if $path eq ''; } - unshift(@args, $path); + unshift(@encoded_args, $path); unless (defined $path && $path =~ s!^/!!) { # in-place strip my $namespace = $c->namespace; if (defined $path) { # cheesy hack to handle path '../foo' - $namespace =~ s{(?:^|/)[^/]+$}{} while $args[0] =~ s{^\.\./}{}; + $namespace =~ s{(?:^|/)[^/]+$}{} while $encoded_args[0] =~ s{^\.\./}{}; } - unshift(@args, $namespace || ''); + unshift(@encoded_args, $namespace || ''); } # join args with '/', or a blank string - my $args = join('/', grep { defined($_) } @args); + my $args = join('/', grep { defined($_) } @encoded_args); $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE $args =~ s!^/+!!; @@ -1403,16 +1460,22 @@ sub uri_for { # somewhat lifted from URI::_query's query_form $query = '?'.join('&', map { my $val = $params->{$_}; - s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go; + #s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go; ## Commented out because seems to lead to double encoding - JNAP s/ /+/g; my $key = $_; $val = '' unless defined $val; (map { my $param = "$_"; - utf8::encode( $param ) if utf8::is_utf8($param); + $param = encode_utf8($param); # using the URI::Escape pattern here so utf8 chars survive $param =~ s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go; $param =~ s/ /+/g; + + $key = encode_utf8($key); + # using the URI::Escape pattern here so utf8 chars survive + $key =~ s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go; + $key =~ s/ /+/g; + "${key}=$param"; } ( ref $val eq 'ARRAY' ? @$val : $val )); } @keys); } @@ -1738,6 +1801,16 @@ sub execute { my $last = pop( @{ $c->stack } ); if ( my $error = $@ ) { + #rethow if this can be handled by middleware + if(blessed $error && ($error->can('as_psgi') || $error->can('code'))) { + foreach my $err (@{$c->error}) { + $c->log->error($err); + } + $c->clear_errors; + $c->log->_flush if $c->log->can('_flush'); + + $error->can('rethrow') ? $error->rethrow : croak $error; + } if ( blessed($error) and $error->isa('Catalyst::Exception::Detach') ) { $error->rethrow if $c->depth > 1; } @@ -1862,8 +1935,8 @@ sub finalize { $c->finalize_error; } + $c->finalize_encoding; $c->finalize_headers unless $c->response->finalized_headers; - $c->finalize_body; } @@ -1917,7 +1990,6 @@ sub finalize_error { # In the case where the error 'knows what it wants', becauses its PSGI # aware, just rethow and let middleware catch it $error->can('rethrow') ? $error->rethrow : croak $error; - croak $error; } else { $c->engine->finalize_error( $c, @_ ) } @@ -1955,6 +2027,47 @@ sub finalize_headers { $response->finalized_headers(1); } +=head2 $c->finalize_encoding + +Make sure your headers and body are encoded properly IF you set an encoding. +See L. + +=cut + +sub finalize_encoding { + my $c = shift; + + my $body = $c->response->body; + + return unless defined($body); + + my $enc = $c->encoding; + + return unless $enc; + + my ($ct, $ct_enc) = $c->response->content_type; + + # Only touch 'text-like' contents + return unless $c->response->content_type =~ /^text|xml$|javascript$/; + + if ($ct_enc && $ct_enc =~ /charset=([^;]*)/) { + if (uc($1) ne uc($enc->mime_name)) { + $c->log->debug("Unicode::Encoding is set to encode in '" . + $enc->mime_name . + "', content type is '$1', not encoding "); + return; + } + } else { + $c->res->content_type($c->res->content_type . "; charset=" . $enc->mime_name); + } + + # Oh my, I wonder what filehandle responses and streams do... - jnap. + # Encode expects plain scalars (IV, NV or PV) and segfaults on ref's + if (ref(\$body) eq 'SCALAR') { + $c->response->body( $c->encoding->encode( $body, $c->_encode_check ) ); + }; +} + =head2 $c->finalize_output An alias for finalize_body. @@ -2114,7 +2227,19 @@ Prepares action. See L. =cut -sub prepare_action { my $c = shift; $c->dispatcher->prepare_action( $c, @_ ) } +sub prepare_action { + my $c = shift; + my $ret = $c->dispatcher->prepare_action( $c, @_); + + if($c->encoding) { + foreach (@{$c->req->arguments}, @{$c->req->captures}) { + $_ = $c->_handle_param_unicode_decoding($_); + } + } + + return $ret; +} + =head2 $c->prepare_body @@ -2165,9 +2290,7 @@ Prepares connection. sub prepare_connection { my $c = shift; - # XXX - This is called on the engine (not the request) to maintain - # Engine::PSGI back compat. - $c->engine->prepare_connection($c); + $c->request->prepare_connection($c); } =head2 $c->prepare_cookies @@ -2250,6 +2373,10 @@ sub log_request { $method ||= ''; $path = '/' unless length $path; $address ||= ''; + + $path =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg; + $path = decode_utf8($path); + $c->log->debug(qq/"$method" request for "$path" from "$address"/); $c->log_request_headers($request->headers); @@ -2434,8 +2561,38 @@ Prepares uploads. sub prepare_uploads { my $c = shift; - $c->engine->prepare_uploads( $c, @_ ); + + my $enc = $c->encoding; + return unless $enc; + + # Uggg we hook prepare uploads to do the encoding crap on post and query + # parameters! Cargo culted from old encoding plugin. Sorry -jnap + for my $key (qw/ parameters query_parameters body_parameters /) { + for my $value ( values %{ $c->request->{$key} } ) { + # N.B. Check if already a character string and if so do not try to double decode. + # http://www.mail-archive.com/catalyst@lists.scsys.co.uk/msg02350.html + # this avoids exception if we have already decoded content, and is _not_ the + # same as not encoding on output which is bad news (as it does the wrong thing + # for latin1 chars for example).. + $value = $c->_handle_unicode_decoding($value); + } + } + for my $value ( values %{ $c->request->uploads } ) { + # skip if it fails for uploads, as we don't usually want uploads touched + # in any way + for my $inner_value ( ref($value) eq 'ARRAY' ? @{$value} : $value ) { + $inner_value->{filename} = try { + $enc->decode( $inner_value->{filename}, $c->_encode_check ) + } catch { + $c->handle_unicode_encoding_exception({ + param_value => $inner_value->{filename}, + error_msg => $_, + encoding_step => 'uploads', + }); + }; + } + } } =head2 $c->prepare_write @@ -2589,18 +2746,15 @@ sub locate_components { my $class = shift; my $config = shift; - my @paths = qw( ::Controller ::C ::Model ::M ::View ::V ); + my @paths = qw( ::M ::Model ::V ::View ::C ::Controller ); my $extra = delete $config->{ search_extra } || []; - push @paths, @$extra; + unshift @paths, @$extra; - my $locator = Module::Pluggable::Object->new( - search_path => [ map { s/^(?=::)/$class/; $_; } @paths ], - %$config - ); - - # XXX think about ditching this sort entirely - my @comps = sort { length $a <=> length $b } $locator->plugins; + my @comps = map { sort { length($a) <=> length($b) } Module::Pluggable::Object->new( + search_path => [ map { s/^(?=::)/$class/; $_; } ($_) ], + %$config + )->plugins } @paths; return @comps; } @@ -2871,7 +3025,9 @@ sub apply_default_middlewares { return $psgi_app; } -=head2 $c->psgi_app +=head2 App->psgi_app + +=head2 App->to_app Returns a PSGI application code reference for the catalyst application C<$c>. This is the bare application without any middlewares @@ -2882,6 +3038,8 @@ reference of your Catalyst application for use in F<.psgi> files. =cut +*to_app = \&psgi_app; + sub psgi_app { my ($app) = @_; my $psgi = $app->engine->build_psgi_app($app); @@ -2910,6 +3068,80 @@ sub setup_home { } } +=head2 $c->setup_encoding + +Sets up the input/output encoding. See L + +=cut + +sub setup_encoding { + my $c = shift; + my $enc = delete $c->config->{encoding}; + $c->encoding( $enc ) if defined $enc; +} + +=head2 handle_unicode_encoding_exception + +Hook to let you customize how encoding errors are handled. By default +we just throw an exception. Receives a hashref of debug information. +Example: + + $c->handle_unicode_encoding_exception({ + param_value => $value, + error_msg => $_, + encoding_step => 'params', + }); + +=cut + +sub handle_unicode_encoding_exception { + my ( $self, $exception_ctx ) = @_; + die $exception_ctx->{error_msg}; +} + +# Some unicode helpers cargo culted from the old plugin. These could likely +# be neater. + +sub _handle_unicode_decoding { + my ( $self, $value ) = @_; + + return unless defined $value; + + ## I think this mess is to support the old nested + if ( ref $value eq 'ARRAY' ) { + foreach ( @$value ) { + $_ = $self->_handle_unicode_decoding($_); + } + return $value; + } + elsif ( ref $value eq 'HASH' ) { + foreach ( values %$value ) { + $_ = $self->_handle_unicode_decoding($_); + } + return $value; + } + else { + return $self->_handle_param_unicode_decoding($value); + } +} + +sub _handle_param_unicode_decoding { + my ( $self, $value ) = @_; + return unless defined $value; # not in love with just ignoring undefs - jnap + + my $enc = $self->encoding; + return try { + $enc->decode( $value, $self->_encode_check ); + } + catch { + $self->handle_unicode_encoding_exception({ + param_value => $value, + error_msg => $_, + encoding_step => 'params', + }); + }; +} + =head2 $c->setup_log Sets up log by instantiating a L object and @@ -3020,7 +3252,7 @@ the plugin name does not begin with C. return $class; } - sub _default_plugins { return qw(Unicode::Encoding) } + sub _default_plugins { return qw() } sub setup_plugins { my ( $class, $plugins ) = @_; @@ -3103,12 +3335,17 @@ which sounds odd but is likely how you expect it to work if you have prior experience with L or if you previously used the plugin L (which is now considered deprecated) +So basically your middleware handles an incoming request from the first +registered middleware, down and handles the response from the last middleware +up. + =cut sub registered_middlewares { my $class = shift; if(my $middleware = $class->_psgi_middleware) { return ( + Catalyst::Middleware::Stash->new, Plack::Middleware::HTTPExceptions->new, Plack::Middleware::RemoveRedundantBody->new, Plack::Middleware::FixMissingBodyInRedirect->new, @@ -3124,7 +3361,7 @@ sub registered_middlewares { sub setup_middleware { my $class = shift; my @middleware_definitions = @_ ? - @_ : reverse(@{$class->config->{'psgi_middleware'}||[]}); + reverse(@_) : reverse(@{$class->config->{'psgi_middleware'}||[]}); my @middleware = (); while(my $next = shift(@middleware_definitions)) { @@ -3190,7 +3427,8 @@ sub registered_data_handlers { if(my $data_handlers = $class->_data_handlers) { return %$data_handlers; } else { - die "You cannot call ->registered_data_handlers until data_handers has been setup"; + $class->setup_data_handlers; + return $class->registered_data_handlers; } } @@ -3579,7 +3817,7 @@ example given above, which uses L to provide either L it installed (if you want the faster XS parser, add it to you project Makefile.PL or dist.ini, cpanfile, etc.) -The C configuation is a hashref whose keys are HTTP Content-Types +The C configuration is a hashref whose keys are HTTP Content-Types (matched against the incoming request type using a regexp such as to be case insensitive) and whose values are coderefs that receive a localized version of C<$_> which is a filehandle object pointing to received body. @@ -3944,6 +4182,8 @@ t0m: Tomas Doran Ulf Edvinsson +vanstyn: Henry Van Styn + Viljo Marrandi C Will Hawes C