X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst.pm;h=3c7dd25f71744dc0f321af2b60e0c411cdc90133;hp=b243772b5574bb8877156a9e4d2be81c510797f9;hb=025d09f99a573f9efde3e001190bb584116ccb32;hpb=7d6820cc9cd445e7a3d0c3094584a5eb31f60eb1 diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index b243772..3c7dd25 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -78,7 +78,9 @@ __PACKAGE__->stats_class('Catalyst::Stats'); # Remember to update this in Catalyst::Runtime as well! -our $VERSION = '5.80018'; +our $VERSION = '5.80021'; +our $PRETTY_VERSION = $VERSION; + $VERSION = eval $VERSION; sub import { @@ -243,6 +245,9 @@ environment with CATALYST_DEBUG or _DEBUG. The environment settings override the application, with _DEBUG having the highest priority. +This sets the log level to 'debug' and enables full debug output on the +error screen. If you only want the latter, see L<< $c->debug >>. + =head2 -Engine Forces Catalyst to use a specific engine. Omit the @@ -262,6 +267,14 @@ is replaced with the uppercased name of your application, any "::" in the name will be replaced with underscores, e.g. MyApp::Web should use MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used. +If none of these are set, Catalyst will attempt to automatically detect the +home directory. If you are working in a development envirnoment, Catalyst +will try and find the directory containing either Makefile.PL, Build.PL or +dist.ini. If the application has been installed into the system (i.e. +you have done C), then Catalyst will use the path to your +application module, without the .pm extension (ie, /foo/MyApp if your +application was installed at /foo/MyApp.pm) + =head2 -Log use Catalyst '-Log=warn,fatal,error'; @@ -923,6 +936,8 @@ You can enable debug mode in several ways: =back +The first three also set the log level to 'debug'. + Calling C<< $c->debug(1) >> has no effect. =cut @@ -1131,7 +1146,7 @@ EOF if ( $class->debug ) { my $name = $class->config->{name} || 'Application'; - $class->log->info("$name powered by Catalyst $Catalyst::VERSION"); + $class->log->info("$name powered by Catalyst $Catalyst::PRETTY_VERSION"); } # Make sure that the application class becomes immutable at this point, @@ -1169,23 +1184,20 @@ EOF return 1; # Explicit return true as people have __PACKAGE__->setup as the last thing in their class. HATE. } - =head2 $app->setup_finalize -A hook to attach modifiers to. -Using C<< after setup => sub{}; >> doesn't work, because of quirky things done for plugin setup. -Also better than C< setup_finished(); >, as that is a getter method. - - sub setup_finalize { - - my $app = shift; +A hook to attach modifiers to. This method does not do anything except set the +C accessor. - ## do stuff, i.e., determine a primary key column for sessions stored in a DB +Applying method modifiers to the C method doesn't work, because of quirky thingsdone for plugin setup. - $app->next::method(@_); +Example: + after setup_finalize => sub { + my $app = shift; - } + ## do stuff here.. + }; =cut @@ -1246,11 +1258,31 @@ sub uri_for { $path .= '/'; } + undef($path) if (defined $path && $path eq ''); + + my $params = + ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} ); + + carp "uri_for called with undef argument" if grep { ! defined $_ } @args; + foreach my $arg (@args) { + utf8::encode($arg) if utf8::is_utf8($arg); + } + s/([^$URI::uric])/$URI::Escape::escapes{$1}/go for @args; + if (blessed $path) { # Action object only. + s|/|%2F|g for @args; + } + if ( blessed($path) ) { # action object - my $captures = [ map { s|/|%2F|; $_; } + my $captures = [ map { s|/|%2F|g; $_; } ( scalar @args && ref $args[0] eq 'ARRAY' ? @{ shift(@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; $path = $c->dispatcher->uri_for_action($action, $captures); if (not defined $path) { @@ -1263,13 +1295,6 @@ sub uri_for { undef($path) if (defined $path && $path eq ''); - my $params = - ( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} ); - - carp "uri_for called with undef argument" if grep { ! defined $_ } @args; - s/([^$URI::uric])/$URI::Escape::escapes{$1}/go for @args; - s|/|%2F| for @args; - unshift(@args, $path); unless (defined $path && $path =~ s!^/!!) { # in-place strip @@ -1718,6 +1743,8 @@ sub finalize { $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; @@ -1942,8 +1969,7 @@ sub prepare { $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; @@ -1973,17 +1999,6 @@ sub prepare_body { $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 ) @@ -2067,19 +2082,165 @@ sub prepare_query_parameters { my $c = shift; $c->engine->prepare_query_parameters( $c, @_ ); +} + +=head2 $c->log_request + +Writes information about the request to the debug logs. This includes: + +=over 4 + +=item * Request method, path, and remote IP address + +=item * Request headers (see L) + +=item * Query keywords (see L) + +=item * Request parameters + +=item * File uploads + +=back + +=cut + +sub log_request { + my $c = shift; + + return unless $c->debug; + + my($dump) = grep {$_->[0] eq 'Request' } $c->dump_these; + my $request = $dump->[1]; + + my ( $method, $path, $address ) = ( $request->method, $request->path, $request->address ); + $method ||= ''; + $path = '/' unless length $path; + $address ||= ''; + $c->log->debug(qq/"$method" request for "$path" from "$address"/); + + $c->log_headers('request', $request->headers); + + if ( my $keywords = $request->query_keywords ) { + $c->log->debug("Query keywords are: $keywords"); + } + + $c->log_request_parameters( query => $request->query_parameters, body => $request->body_parameters ); + + $c->log_request_uploads($request); +} + +=head2 $c->log_response + +Writes information about the response to the debug logs. This includes: + +=over 4 - 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}; +=item * Response status code + +=item * Response headers (see L) + +=back + +=cut + +sub log_response { + my $c = shift; + + return unless $c->debug; + + my($dump) = grep {$_->[0] eq 'Response' } $c->dump_these; + my $response = $dump->[1]; + + $c->log->debug( + sprintf( + 'Response Code: %s; Content-Type: %s; Content-Length: %s', + $response->status || 'unknown', + $response->headers->header('Content-Type') || 'unknown', + $response->headers->header('Content-Length') || 'unknown' + ) + ); +} + +=head2 $c->log_request_parameters( query => {}, body => {} ) + +Logs request parameters to debug logs + +=cut + +sub log_request_parameters { + my $c = shift; + my %all_params = @_; + + return unless $c->debug; + + my $column_width = Catalyst::Utils::term_width() - 44; + foreach my $type (qw(query body)) { + my $params = $all_params{$type}; + next if ! keys %$params; + my $t = Text::SimpleTable->new( [ 35, 'Parameter' ], [ $column_width, 'Value' ] ); + for my $key ( sort keys %$params ) { + my $param = $params->{$key}; my $value = defined($param) ? $param : ''; - $t->row( $key, - ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value ); + $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value ); } - $c->log->debug( "Query Parameters are:\n" . $t->draw ); + $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 file size are all included in +the debug logs. + +=cut + +sub log_request_uploads { + my $c = shift; + my $request = shift; + return unless $c->debug; + my $uploads = $request->uploads; + if ( keys %$uploads ) { + my $t = Text::SimpleTable->new( + [ 12, 'Parameter' ], + [ 26, 'Filename' ], + [ 18, 'Type' ], + [ 9, 'Size' ] + ); + 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 ); + } + } + $c->log->debug( "File Uploads are:\n" . $t->draw ); + } +} + +=head2 $c->log_headers($type => $headers) + +Logs L (either request or response) to the debug logs. + +=cut + +sub log_headers { + my $c = shift; + my $type = shift; + my $headers = shift; # an HTTP::Headers instance + + return unless $c->debug; + + my $t = Text::SimpleTable->new( [ 35, 'Header Name' ], [ 40, 'Value' ] ); + $headers->scan( + sub { + my ( $name, $value ) = @_; + $t->row( $name, $value ); + } + ); + $c->log->debug( ucfirst($type) . " Headers:\n" . $t->draw ); +} + + =head2 $c->prepare_read Prepares the input for reading. @@ -2106,22 +2267,6 @@ sub prepare_uploads { my $c = shift; $c->engine->prepare_uploads( $c, @_ ); - - if ( $c->debug && keys %{ $c->request->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 $u ( ref $upload eq 'ARRAY' ? @{$upload} : ($upload) ) { - $t->row( $key, $u->filename, $u->type, $u->size ); - } - } - $c->log->debug( "File Uploads are:\n" . $t->draw ); - } } =head2 $c->prepare_write @@ -2224,8 +2369,11 @@ sub setup_components { } for my $component (@comps) { - $class->components->{ $component } = $class->setup_component($component); - for my $component ($class->expand_component_module( $component, $config )) { + my $instance = $class->components->{ $component } = $class->setup_component($component); + my @expanded_components = $instance->can('expand_modules') + ? $instance->expand_modules( $component, $config ) + : $class->expand_component_module( $component, $config ); + for my $component (@expanded_components) { next if $comps{$component}; $class->_controller_init_base_classes($component); # Also cover inner packages $class->components->{ $component } = $class->setup_component($component);