use bytes;
use B::Hooks::EndOfScope ();
use Catalyst::Exception;
+use Catalyst::Exception::Detach;
+use Catalyst::Exception::Go;
use Catalyst::Log;
use Catalyst::Request;
use Catalyst::Request::Upload;
our $COUNT = 1;
our $START = time;
our $RECURSION = 1000;
-our $DETACH = "catalyst_detach\n";
-our $GO = "catalyst_go\n";
+our $DETACH = Catalyst::Exception::Detach->new;
+our $GO = Catalyst::Exception::Go->new;
#I imagine that very few of these really need to be class variables. if any.
#maybe we should just make them attributes with a default?
# Remember to update this in Catalyst::Runtime as well!
-our $VERSION = '5.80004';
+our $VERSION = '5.80007';
{
my $dev_version = $VERSION =~ /_\d{2}$/;
}
my $meta = Moose::Meta::Class->initialize($caller);
- #Moose->import({ into => $caller }); #do we want to do this?
-
unless ( $caller->isa('Catalyst') ) {
my @superclasses = ($meta->superclasses, $class, 'Catalyst::Controller');
$meta->superclasses(@superclasses);
}
+ # Avoid possible C3 issues if 'Moose::Object' is already on RHS of MyApp
+ $meta->superclasses(grep { $_ ne 'Moose::Object' } $meta->superclasses);
+
unless( $meta->has_method('meta') ){
$meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } );
}
$caller->setup_home;
}
+sub _application { $_[0] }
+
=head1 NAME
Catalyst - The Elegant MVC Web Application Framework
$c->error(0);
}
-# search components given a name and some prefixes
sub _comp_search_prefixes {
+ my $c = shift;
+ return map $c->components->{ $_ }, $c->_comp_names_search_prefixes(@_);
+}
+
+# search components given a name and some prefixes
+sub _comp_names_search_prefixes {
my ( $c, $name, @prefixes ) = @_;
my $appclass = ref $c || $c;
my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::';
my $query = ref $name ? $name : qr/^$name$/i;
my @result = grep { $eligible{$_} =~ m{$query} } keys %eligible;
- return map { $c->components->{ $_ } } @result if @result;
+ return @result if @result;
# if we were given a regexp to search against, we're done.
return if ref $name;
# regexp fallback
$query = qr/$name/i;
- @result = map { $c->components->{ $_ } } grep { $eligible{ $_ } =~ m{$query} } keys %eligible;
+ @result = grep { $eligible{ $_ } =~ m{$query} } keys %eligible;
# no results? try against full names
if( !@result ) {
- @result = map { $c->components->{ $_ } } grep { m{$query} } keys %eligible;
+ @result = grep { m{$query} } keys %eligible;
}
# don't warn if we didn't find any results, it just might not exist
my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::';
- my @names = map { s{$filter}{}; $_; } $c->_comp_search_prefixes( undef, @prefixes );
+ my @names = map { s{$filter}{}; $_; }
+ $c->_comp_names_search_prefixes( undef, @prefixes );
+
return @names;
}
$class->log->_flush() if $class->log->can('_flush');
# Make sure that the application class becomes immutable at this point,
- # which ensures that it gets an inlined constructor. This means that it
- # works even if the user has added a plugin which contains a new method.
- # Note however that we have to do the work on scope end, so that method
- # modifiers work correctly in MyApp (as you have to call setup _before_
- # applying modifiers).
B::Hooks::EndOfScope::on_scope_end {
return if $@;
my $meta = Class::MOP::get_metaclass_by_name($class);
- if ( $meta->is_immutable && ! { $meta->immutable_options }->{inline_constructor} ) {
+ if (
+ $meta->is_immutable
+ && ! { $meta->immutable_options }->{replace_constructor}
+ && (
+ $class->isa('Class::Accessor::Fast')
+ || $class->isa('Class::Accessor')
+ )
+ ) {
warn "You made your application class ($class) immutable, "
- . "but did not inline the constructor.\n"
- . "This will break catalyst, please pass "
- . "(replace_constructor => 1) when making your class immutable.\n";
+ . "but did not inline the\nconstructor. "
+ . "This will break catalyst, as your app \@ISA "
+ . "Class::Accessor(::Fast)?\nPlease pass "
+ . "(replace_constructor => 1)\nwhen making your class immutable.\n";
}
- $meta->make_immutable(replace_constructor => 1) unless $meta->is_immutable;
+ $meta->make_immutable(replace_constructor => 1)
+ unless $meta->is_immutable;
};
$class->setup_finalize;
( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
carp "uri_for called with undef argument" if grep { ! defined $_ } @args;
- s/([^A-Za-z0-9\-_.!~*'()])/$URI::Escape::escapes{$1}/go for @args;
+ s/([^$URI::uric])/$URI::Escape::escapes{$1}/go for @args;
unshift(@args, $path);
my $key = $_;
$val = '' unless defined $val;
(map {
- $_ = "$_";
- utf8::encode( $_ ) if utf8::is_utf8($_);
+ my $param = "$_";
+ utf8::encode( $param ) if utf8::is_utf8($param);
# using the URI::Escape pattern here so utf8 chars survive
- s/([^A-Za-z0-9\-_.!~*'()])/$URI::Escape::escapes{$1}/go;
- s/ /+/g;
- "${key}=$_"; } ( ref $val eq 'ARRAY' ? @$val : $val ));
+ $param =~ s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go;
+ $param =~ s/ /+/g;
+ "${key}=$param"; } ( ref $val eq 'ARRAY' ? @$val : $val ));
} @keys);
}
my $last = pop( @{ $c->stack } );
if ( my $error = $@ ) {
- if ( !ref($error) and $error eq $DETACH ) {
- die $DETACH if($c->depth > 1);
+ if ( blessed($error) and $error->isa('Catalyst::Exception::Detach') ) {
+ $error->rethrow if $c->depth > 1;
}
- elsif ( !ref($error) and $error eq $GO ) {
- die $GO if($c->depth > 0);
+ elsif ( blessed($error) and $error->isa('Catalyst::Exception::Go') ) {
+ $error->rethrow if $c->depth > 0;
}
else {
unless ( ref $error ) {
$c->finalize_body;
}
+ $c->log_response;
+
if ($c->use_stats) {
my $elapsed = sprintf '%f', $c->stats->elapsed;
my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed;
$path = '/' unless length $path;
my $address = $c->req->address || '';
- $c->log->debug(qq/"$method" request for "$path" from "$address"/)
- if $c->debug;
+ $c->log_request;
$c->prepare_action;
$c->engine->prepare_body( $c, @_ );
$c->prepare_parameters;
$c->prepare_uploads;
-
- if ( $c->debug && keys %{ $c->req->body_parameters } ) {
- my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
- for my $key ( sort keys %{ $c->req->body_parameters } ) {
- my $param = $c->req->body_parameters->{$key};
- my $value = defined($param) ? $param : '';
- $t->row( $key,
- ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
- }
- $c->log->debug( "Body Parameters are:\n" . $t->draw );
- }
}
=head2 $c->prepare_body_chunk( $chunk )
my $c = shift;
$c->engine->prepare_query_parameters( $c, @_ );
+}
- if ( $c->debug && keys %{ $c->request->query_parameters } ) {
- my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ 36, 'Value' ] );
- for my $key ( sort keys %{ $c->req->query_parameters } ) {
- my $param = $c->req->query_parameters->{$key};
- my $value = defined($param) ? $param : '';
- $t->row( $key,
- ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
+=head2 $c->apply_parameter_debug_filters($params)
+
+=cut
+
+sub _apply_parameter_debug_filters {
+ my $c = shift;
+ my $type = shift;
+ my $params = shift;
+
+ # take a copy since we don't want to modify the original
+ my $filtered_params = {%$params};
+
+ my @filters;
+
+ my $filter_param_config = $c->config->{Debug}->{param_filters};
+ if ( ref($filter_param_config) eq 'HASH' ) {
+
+ # filters broken out by parameter type (i.e. body, query, all)
+ my $type_filters = $filter_param_config->{$type} || [];
+ $type_filters = [$type_filters] if ref $type_filters ne 'ARRAY';
+
+ my $all_filters = $filter_param_config->{'all'} || [];
+ $all_filters = [$all_filters] if ref $all_filters ne 'ARRAY';
+
+ @filters = $c->_normalize_debug_filters( [ @$type_filters, @$all_filters ] );
+ } elsif ($filter_param_config) {
+ @filters = $c->_normalize_debug_filters($filter_param_config);
+ }
+
+ # allow callback to modify each parameter
+ foreach my $k ( keys %$filtered_params ) {
+
+ # apply filters to each param
+ foreach my $f (@filters) {
+
+ # take a copy of the key to avoid the callback inadvertantly
+ # modifying things
+ my $copy_key = $k;
+
+ my $returned = $f->( $copy_key => $filtered_params->{$k} );
+
+ if ( defined $returned ) {
+
+ # if no value is returned, we assume the filter chose not to modify anything
+ # otherwise, the returned value is the logged value
+ $filtered_params->{$k} = $returned;
+
+ last; # skip the rest of the filters since this one matched
+ }
}
- $c->log->debug( "Query Parameters are:\n" . $t->draw );
}
+ return $filtered_params;
}
-=head2 $c->prepare_read
+# turn debug filters into a list of CodeRef's
+sub _normalize_debug_filters {
+ my $c = shift;
-Prepares the input for reading.
+ my @filters = ref( $_[0] ) eq 'ARRAY' ? @{ $_[0] } : grep { defined $_ } @_;
-=cut
+ my @normalized = map { _make_filter_callback($_) } @filters;
-sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
+ return @normalized;
+}
-=head2 $c->prepare_request
+sub _make_filter_callback {
+ my $filter = shift;
-Prepares the engine request.
+ my $filter_str = '[FILTERED]';
+ if ( ref($filter) eq 'Regexp' ) {
+ return sub { return $_[0] =~ $filter ? $filter_str : undef };
+ } elsif ( ref($filter) eq 'CODE' ) {
+ return $filter;
+ } else {
+ return sub { return $_[0] eq $filter ? $filter_str : undef };
+ }
+}
+
+=head2 $c->log_request
+
+Writes information about the request to the debug logs. This includes:
+
+=over 4
+
+=item * Request method, path and remote IP
+
+=item * Query keywords (see L<Catalyst::Request/query_keywords>)
+
+=item * Request parameters (see L</log_request_parameters>)
+
+=item * File uploads
+
+=back
=cut
-sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
+sub log_request {
+ my $c = shift;
-=head2 $c->prepare_uploads
+ return unless $c->debug;
-Prepares uploads.
+ my ( $method, $path, $address ) = ( $c->req->method, $c->req->path, $c->req->address );
+ $method ||= '';
+ $path = '/' unless length $path;
+ $address ||= '';
+ $c->log->debug(qq/"$method" request for "$path" from "$address"/);
+
+ if ( my $keywords = $c->req->query_keywords ) {
+ $c->log->debug("Query keywords are: $keywords");
+ }
+
+ $c->log_request_parameters( query => $c->req->query_parameters, body => $c->req->body_parameters );
+
+ $c->log_request_uploads;
+}
+
+=head2 $c->log_response
+
+Writes information about the response to the debug logs. This includes:
+
+=over 4
+
+=item * Response status code
+
+=item * Response headers (see L</log_headers>)
+
+=back
+
+This logging is not enabled by default. To enable, you must set a flag in your Catalyst config:
+
+ __PACKAGE__->config( Debug => { log_response => 1 } );
=cut
-sub prepare_uploads {
+sub log_response {
my $c = shift;
- $c->engine->prepare_uploads( $c, @_ );
+ return unless $c->debug && $c->config->{Debug}->{log_response};
+
+ $c->log->debug('Response Status: ' . $c->response->status);
+ $c->log_headers('response', $c->response->headers);
+}
+
+=head2 $c->log_request_parameters( query => {}, body => {} )
+
+Logs request parameters to debug logs
+
+If you have sensitive data that you do not want written to the Catalyst
+debug logs, you can set options in your config to filter those values out.
+There are a few different ways you can set these up depending on what
+exactly you need to filter.
+
+=head3 Filtering parameters by name
+
+The most basic means of filtering is to add an entry into your config
+as shown below. You can have a simple scalar to just filter a
+single parameter or an ARRAY ref to filter out multiple params.
+
+ # filters a single param
+ __PACKAGE__->config( Debug => { param_filters => 'param_name' } );
+
+ # filters multiple params
+ __PACKAGE__->config( Debug => { param_filters => [qw(param1 param2)] } );
+
+When the debug logs are generated for a given request, any parameters
+(query or body) that exactly match the specified value(s) will have
+their values replaced with '[FILTERED]'. For instance:
+
+ [debug] Query Parameters are:
+ .-------------------------------------+--------------------------------------.
+ | Parameter | Value |
+ +-------------------------------------+--------------------------------------+
+ | param_name | [FILTERED] |
+ .-------------------------------------+--------------------------------------.
+
+=head3 Filtering parameters by regular expression
+
+If you have a set of parameters you need to filter, you can specify a
+regular expression that will be used to match against parameter names.
+
+ # filters parameters starting with "private."
+ __PACKAGE__->config( Debug => { param_filters => qr/^private\./ } );
+
+ # filters parameters named "param1" or starting with "private." or "secret."
+ __PACKAGE__->config( Debug => { param_filters => [ 'param1', qr/^private\./, qr/^secret\./ ] } );
+
+Notice on the second example, the ARRAY ref contains a string as well
+as two regular expressions. This should DWIM and filter parameters that
+match any of the filters specified.
+
+=head3 Filtering parameters by callback
- if ( $c->debug && keys %{ $c->request->uploads } ) {
+If you want even more flexible filtering, you can specify an anonymous
+subroutine. The subroutine is given the parameter name and value and
+is expected to return the new value that will be show in the debug log.
+An C<undef> return value indicates that no change should be made to
+the value.
+
+ # transform any "password" param to "********"
+ __PACKAGE__->config(
+ Debug => {
+ param_filters => sub { my ( $k, $v ) = @_; return unless $k eq 'password'; return '*' x 8; }
+ }
+ );
+
+ # combine with other filtering methods
+ __PACKAGE__->config(
+ Debug => {
+ param_filters => [
+ 'simple_param_name',
+ qr/^private\./,
+ sub { my ( $k, $v ) = @_; return unless $k eq 'password'; return '*' x 8; },
+ ]
+ }
+ );
+
+An example of the debug log for a request with
+C<password=secret&some_other_param=some_other_value> would be:
+
+ [debug] Body Parameters are:
+ .-------------------------------------+--------------------------------------.
+ | Parameter | Value |
+ +-------------------------------------+--------------------------------------+
+ | some_other_param | some_other_value |
+ | password | ******** |
+ .-------------------------------------+--------------------------------------.
+
+=head3 Filtering by parameter location
+
+If you have a different set of filters based on how they were passed
+(query vs. body vs. all), you can specify a HASH ref with different sets of
+filters:
+
+ # filters all body parameters
+ __PACKAGE__->config( Debug => { param_filters => { body => qr// } } );
+
+ # filters query parameters starting with "private."
+ __PACKAGE__->config( Debug => { param_filters => { query => qr/^private\./ } } );
+
+ # filters all parameters (query or body) through the specified callback
+ __PACKAGE__->config(
+ Debug => {
+ param_filters => {
+ all => sub { return unless $_[0] eq 'fizzbuzz'; return 'FIZZBUZZ FILTER' }
+ }
+ }
+ );
+
+Of course, you can use any of the above filtering methods with these
+"location-specific" filters:
+
+ # body parameter filters
+ __PACKAGE__->config(
+ Debug => {
+ param_filters => {
+ body => [
+ 'some_param',
+ qr/^private\./,
+ sub { return 'XXX' if shift eq 'other_param' }
+ ]
+ }
+ }
+ );
+
+ # query parameter filters
+ __PACKAGE__->config(
+ Debug => {
+ param_filters => {
+ body => [
+ 'some_param',
+ qr/^private\./,
+ sub { return 'XXX' if shift eq 'other_param' }
+ ]
+ }
+ }
+ );
+
+ # query parameter filters
+ __PACKAGE__->config( Debug => { param_filters => { all => [qw(foo bar)] } } );
+
+=cut
+
+sub log_request_parameters {
+ my $c = shift;
+ my %all_params = @_;
+
+ my $column_width = Catalyst::Utils::term_width() - 44;
+ foreach my $type (qw(query body)) {
+ my $filtered_params = $c->_apply_parameter_debug_filters( $type, $all_params{$type} || {} );
+ next unless keys %$filtered_params;
+ my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ $column_width, 'Value' ] );
+ for my $key ( sort keys %$filtered_params ) {
+ my $param = $filtered_params->{$key};
+ my $value = defined($param) ? $param : '';
+ $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value );
+ }
+ $c->log->debug( ucfirst($type) . " Parameters are:\n" . $t->draw );
+ }
+}
+
+=head2 $c->log_request_uploads
+
+Logs file uploads included in the request to the debug logs.
+The parameter name, filename, file type and size are all included in
+the debug logs.
+
+=cut
+
+sub log_request_uploads {
+ my $c = shift;
+ my $uploads = $c->req->uploads;
+ if ( keys %$uploads ) {
my $t = Text::SimpleTable->new(
[ 12, 'Parameter' ],
[ 26, 'Filename' ],
[ 18, 'Type' ],
[ 9, 'Size' ]
);
- for my $key ( sort keys %{ $c->request->uploads } ) {
- my $upload = $c->request->uploads->{$key};
+ for my $key ( sort keys %$uploads ) {
+ my $upload = $uploads->{$key};
for my $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) {
$t->row( $key, $u->filename, $u->type, $u->size );
}
}
}
+=head2 $c->log_headers($type => $headers)
+
+Writes HTTP::Headers to debug logs, applying filters as configured.
+
+Similarly to how L</log_request_parameters> is configured, you can
+configure Catalyst to filter response header values to avoid writing
+sensitive data to your logs (i.e. cookie values, etc). Take a look at
+the examples in L</log_request_parameters> as this configuration works
+virtually the same way. Here are a few examples:
+
+ # filters all "Set-Cookie" headers from response logging
+ __PACKAGE__->config(Debug => { response_header_filters => 'Set-Cookie' } );
+
+ # filters only the value of the cookie (and leaves the name, path, expiration)
+ __PACKAGE__->config(
+ Debug => {
+ response_header_filters => sub {
+ my ( $n, $v ) = @_;
+ return unless $n eq 'Set-Cookie';
+ $v =~ s/^.*?;//;
+ return $v;
+ },
+ }
+ );
+
+=cut
+
+sub log_headers {
+ my $c = shift;
+ my $type = shift;
+ my $headers = shift; # an HTTP::Headers instance
+
+ my $filtered = $c->_apply_header_debug_filters( $type, $headers );
+
+ my $t = Text::SimpleTable->new( [ 35, 'Header Name' ], [ 40, 'Value' ] );
+ $filtered->scan(
+ sub {
+ my ( $name, $value ) = @_;
+ $t->row( $name, $value );
+ }
+ );
+ $c->log->debug( ucfirst($type) . " Headers:\n" . $t->draw );
+}
+
+# Applies debug filters to $headers and returns a new HTTP::Headers object which has (potentially) filtered values.
+sub _apply_header_debug_filters {
+ my $c = shift;
+ my $type = shift;
+ my $headers = shift;
+
+ my @header_filters = $c->_normalize_debug_filters( $c->config->{Debug}->{ $type . '_header_filters' } );
+ my $filtered_headers = HTTP::Headers->new();
+ foreach my $name ( $headers->header_field_names ) {
+ my @values = $headers->header($name);
+
+ # headers can be multi-valued
+ foreach my $value (@values) {
+ foreach my $f (@header_filters) {
+ my $new_value = $f->( $name, $value );
+
+ # if a defined value is returned, we use that
+ if ( defined $new_value ) {
+ $value = $new_value;
+ last; # skip the rest of the filters
+ }
+ }
+ $filtered_headers->push_header( $name, $value );
+ }
+ }
+ return $filtered_headers;
+}
+
+=head2 $c->prepare_read
+
+Prepares the input for reading.
+
+=cut
+
+sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) }
+
+=head2 $c->prepare_request
+
+Prepares the engine request.
+
+=cut
+
+sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) }
+
+=head2 $c->prepare_uploads
+
+Prepares uploads.
+
+=cut
+
+sub prepare_uploads {
+ my $c = shift;
+
+ $c->engine->prepare_uploads( $c, @_ );
+}
+
=head2 $c->prepare_write
Prepares the output for writing.
$class->_plugins( {} ) unless $class->_plugins;
$plugins ||= [];
- my @plugins = map { s/\A\+// ? $_ : "Catalyst::Plugin::$_" } @$plugins;
-
+ my @plugins = Catalyst::Utils::resolve_namespace($class . '::Plugin', 'Catalyst::Plugin', @$plugins);
+
for my $plugin ( reverse @plugins ) {
Class::MOP::load_class($plugin);
my $meta = find_meta($plugin);
grep { $_ && blessed($_) && $_->isa('Moose::Meta::Role') }
map { find_meta($_) }
@plugins;
-
+
Moose::Util::apply_all_roles(
$class => @roles
) if @roles;
=head1 LICENSE
-This library 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
projects / catagits/Catalyst-Runtime.git / blobdiff