X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FCatalyst.pm;h=34d3d58c5e79abed1cb2111e6373103328db3134;hb=e8b299689361f7f8538d0f7adf70fc86fecba8b2;hp=495a7158153b8682e2fc2b1c21b4fca28c121a4d;hpb=ec0b45423682578553b8b7ed1c87a34ba0fe17f6;p=catagits%2FCatalyst-Runtime.git diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index 495a715..34d3d58 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -78,8 +78,7 @@ __PACKAGE__->stats_class('Catalyst::Stats'); # Remember to update this in Catalyst::Runtime as well! -our $VERSION = '5.80020'; -$VERSION = eval $VERSION; +our $VERSION = '5.80022'; sub import { my ( $class, @arguments ) = @_; @@ -638,7 +637,13 @@ If you want to search for controllers, pass in a regexp as the argument. sub controller { my ( $c, $name, @args ) = @_; + my $appclass = ref($c) || $c; if( $name ) { + unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps + my $comps = $c->components; + my $check = $appclass."::Controller::".$name; + return $c->_filter_component( $comps->{$check}, @args ) if exists $comps->{$check}; + } my @result = $c->_comp_search_prefixes( $name, qw/Controller C/ ); return map { $c->_filter_component( $_, @args ) } @result if ref $name; return $c->_filter_component( $result[ 0 ], @args ); @@ -672,6 +677,11 @@ sub model { my ( $c, $name, @args ) = @_; my $appclass = ref($c) || $c; if( $name ) { + unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps + my $comps = $c->components; + my $check = $appclass."::Model::".$name; + return $c->_filter_component( $comps->{$check}, @args ) if exists $comps->{$check}; + } my @result = $c->_comp_search_prefixes( $name, qw/Model M/ ); return map { $c->_filter_component( $_, @args ) } @result if ref $name; return $c->_filter_component( $result[ 0 ], @args ); @@ -726,6 +736,11 @@ sub view { my $appclass = ref($c) || $c; if( $name ) { + unless ( ref($name) ) { # Direct component hash lookup to avoid costly regexps + my $comps = $c->components; + my $check = $appclass."::View::".$name; + return $c->_filter_component( $comps->{$check}, @args ) if exists $comps->{$check}; + } my @result = $c->_comp_search_prefixes( $name, qw/View V/ ); return map { $c->_filter_component( $_, @args ) } @result if ref $name; return $c->_filter_component( $result[ 0 ], @args ); @@ -1182,23 +1197,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. +A hook to attach modifiers to. This method does not do anything except set the +C accessor. - sub setup_finalize { +Applying method modifiers to the C method doesn't work, because of quirky thingsdone for plugin setup. - my $app = shift; - - ## do stuff, i.e., determine a primary key column for sessions stored in a DB - - $app->next::method(@_); +Example: + after setup_finalize => sub { + my $app = shift; - } + ## do stuff here.. + }; =cut @@ -1265,6 +1277,9 @@ sub uri_for { ( 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; @@ -1293,17 +1308,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; - - foreach my $arg (@args) { - utf8::encode($arg) if utf8::is_utf8($arg); - } - 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 @@ -1317,7 +1321,7 @@ sub uri_for { # join args with '/', or a blank string my $args = join('/', grep { defined($_) } @args); $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE - $args =~ s!^/+!!; +# $args =~ s!^/+!!; my $base = $c->req->base; my $class = ref($base); $base =~ s{(?models, and views; they can save you a lot of work.

- 
script/${prefix}_create.pl -help
+ 
script/${prefix}_create.pl --help

Also, be sure to check out the vast and growing collection of plugins for Catalyst on CPAN; you are likely to find what you need there. @@ -1751,6 +1756,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; @@ -1943,7 +1950,7 @@ sub prepare { #surely this is not the most efficient way to do things... $c->stats($class->stats_class->new)->enable($c->use_stats); - if ( $c->debug ) { + if ( $c->debug || $c->config->{enable_catalyst_header} ) { $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION ); } @@ -1975,8 +1982,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; @@ -2006,17 +2012,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 ) @@ -2100,55 +2095,156 @@ sub prepare_query_parameters { 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 ); - } - $c->log->debug( "Query Parameters are:\n" . $t->draw ); +=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 * 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_request_headers($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->prepare_read +=head2 $c->log_response -Prepares the input for reading. +Writes information about the response to the debug logs by calling +C<< $c->log_response_status_line >> and C<< $c->log_response_headers >>. =cut -sub prepare_read { my $c = shift; $c->engine->prepare_read( $c, @_ ) } +sub log_response { + my $c = shift; -=head2 $c->prepare_request + return unless $c->debug; -Prepares the engine request. + my($dump) = grep {$_->[0] eq 'Response' } $c->dump_these; + my $response = $dump->[1]; + + $c->log_response_status_line($response); + $c->log_response_headers($response->headers); +} + +=head2 $c->log_response_status_line($response) + +Writes one line of information about the response to the debug logs. This includes: + +=over 4 + +=item * Response status code + +=item * Content-Type header (if present) + +=item * Content-Length header (if present) + +=back =cut -sub prepare_request { my $c = shift; $c->engine->prepare_request( $c, @_ ) } +sub log_response_status_line { + my ($c, $response) = @_; -=head2 $c->prepare_uploads + $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' + ) + ); +} -Prepares uploads. +=head2 $c->log_response_headers($headers); + +Hook method which can be wrapped by plugins to log the responseheaders. +No-op in the default implementation. =cut -sub prepare_uploads { - my $c = shift; +sub log_response_headers {} - $c->engine->prepare_uploads( $c, @_ ); +=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 ); + } + $c->log->debug( ucfirst($type) . " Parameters are:\n" . $t->draw ); + } +} - if ( $c->debug && keys %{ $c->request->uploads } ) { +=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 %{ $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 ); } @@ -2157,6 +2253,68 @@ sub prepare_uploads { } } +=head2 $c->log_request_headers($headers); + +Hook method which can be wrapped by plugins to log the request headers. +No-op in the default implementation. + +=cut + +sub log_request_headers {} + +=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 $column_width = Catalyst::Utils::term_width() - 28; + my $t = Text::SimpleTable->new( [ 15, 'Header Name' ], [ $column_width, '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. + +=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. @@ -2629,13 +2787,8 @@ the plugin name does not begin with C. if $plugin->isa( 'Catalyst::Component' ); $proto->_plugins->{$plugin} = 1; unless ($instant) { - no strict 'refs'; - if ( my $meta = Class::MOP::get_metaclass_by_name($class) ) { - my @superclasses = ($plugin, $meta->superclasses ); - $meta->superclasses(@superclasses); - } else { - unshift @{"$class\::ISA"}, $plugin; - } + my $meta = Class::MOP::get_metaclass_by_name($class); + $meta->superclasses($plugin, $meta->superclasses); } return $class; } @@ -3010,6 +3163,8 @@ Robert Sedlacek C<< >> sky: Arthur Bergman +szbalint: Balint Szilakszi + t0m: Tomas Doran Ulf Edvinsson