r55006 - in /trunk/libcatalyst-perl: ./ debian/ lib/ lib/Catalyst/ lib/Catalyst/DispatchType/ lib/Catalyst/Engine/ t/aggregate/
eloy at users.alioth.debian.org
eloy at users.alioth.debian.org
Mon Mar 29 09:49:53 UTC 2010
Author: eloy
Date: Mon Mar 29 09:49:46 2010
New Revision: 55006
URL: http://svn.debian.org/wsvn/pkg-perl/?sc=1&rev=55006
Log:
new upstream version
Modified:
trunk/libcatalyst-perl/Changes
trunk/libcatalyst-perl/META.yml
trunk/libcatalyst-perl/Makefile.PL
trunk/libcatalyst-perl/debian/changelog
trunk/libcatalyst-perl/lib/Catalyst.pm
trunk/libcatalyst-perl/lib/Catalyst/DispatchType/Chained.pm
trunk/libcatalyst-perl/lib/Catalyst/DispatchType/Index.pm
trunk/libcatalyst-perl/lib/Catalyst/Engine.pm
trunk/libcatalyst-perl/lib/Catalyst/Engine/FastCGI.pm
trunk/libcatalyst-perl/lib/Catalyst/Engine/HTTP.pm
trunk/libcatalyst-perl/lib/Catalyst/Runtime.pm
trunk/libcatalyst-perl/t/aggregate/unit_core_uri_for.t
trunk/libcatalyst-perl/t/aggregate/unit_core_uri_for_action.t
Modified: trunk/libcatalyst-perl/Changes
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/Changes?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/Changes (original)
+++ trunk/libcatalyst-perl/Changes Mon Mar 29 09:49:46 2010
@@ -1,4 +1,31 @@
# This file documents the revision history for Perl extension Catalyst.
+
+5.80022 2010-03-28 19:43:01
+
+ New features:
+ - Log an extra line in debug mode with the response status code,
+ the content type and content length if available.
+
+ Refactoring / optimizations:
+ - Display of the end of hit debug messages has been factored out into
+ log_headers, log_request, log_request_headers, log_response,
+ log_response_status_line and log_response_headers methods so that
+ plugins which customise how much information is shown on the debug
+ screen as easy to write.
+ - Make all logging of request and response state get the information from
+ $c->dump_these so that there is a unified point from which to hook
+ in parameter filtering (for example).
+ - $c->model/view/controller have become a lot faster for non-regexp names
+ by using direct hash lookup instead of looping.
+ - IP address => hostname mapping for the server is only done once and cached
+ by Catalyst::Engine::HTTP to somewhat mitigate the problem of people
+ developing on machines pointed at slow DNS servers.
+
+ Bugs fixed:
+ - DispatchType::Index's uri_for_action only returns for actions registered
+ with it (prevents 'index :Path' or similar resolving to the wrong URI)
+ - Make sure to construct Upload objects properly, even if there are
+ multiple Content-Type headers (Closes RT#55976).
5.80021 2010-03-03 23:02:01
Modified: trunk/libcatalyst-perl/META.yml
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/META.yml?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/META.yml (original)
+++ trunk/libcatalyst-perl/META.yml Mon Mar 29 09:49:46 2010
@@ -64,4 +64,4 @@
homepage: http://dev.catalyst.perl.org/
license: http://dev.perl.org/licenses/
repository: http://dev.catalyst.perl.org/repos/Catalyst/Catalyst-Runtime/
-version: 5.80021
+version: 5.80022
Modified: trunk/libcatalyst-perl/Makefile.PL
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/Makefile.PL?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/Makefile.PL (original)
+++ trunk/libcatalyst-perl/Makefile.PL Mon Mar 29 09:49:46 2010
@@ -101,7 +101,8 @@
you also install the development tools package Catalyst::Devel.
perl -MCPANPLUS -e 'install Catalyst::Devel' # or
- perl -MCPAN -e 'install Catalyst::Devel'
+ perl -MCPAN -e 'install Catalyst::Devel' # or
+ cpanm Catalyst::Devel
To get some commonly used plugins, as well as the TT view and DBIC
model, install Task::Catalyst in the same way.
Modified: trunk/libcatalyst-perl/debian/changelog
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/debian/changelog?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/debian/changelog (original)
+++ trunk/libcatalyst-perl/debian/changelog Mon Mar 29 09:49:46 2010
@@ -1,3 +1,9 @@
+libcatalyst-perl (5.80022-1) UNRELEASED; urgency=low
+
+ * New upstream release
+
+ -- Krzysztof Krzyżaniak (eloy) <eloy at debian.org> Mon, 29 Mar 2010 11:46:54 +0200
+
libcatalyst-perl (5.80021-1) unstable; urgency=low
* New upstream release
Modified: trunk/libcatalyst-perl/lib/Catalyst.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/lib/Catalyst.pm?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/lib/Catalyst.pm (original)
+++ trunk/libcatalyst-perl/lib/Catalyst.pm Mon Mar 29 09:49:46 2010
@@ -78,7 +78,7 @@
# Remember to update this in Catalyst::Runtime as well!
-our $VERSION = '5.80021';
+our $VERSION = '5.80022';
our $PRETTY_VERSION = $VERSION;
$VERSION = eval $VERSION;
@@ -640,7 +640,13 @@
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 );
@@ -674,6 +680,11 @@
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 );
@@ -728,6 +739,11 @@
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 );
@@ -1500,7 +1516,7 @@
<a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AModel%3A%3A&mode=all">models</a>, and
<a href="http://cpansearch.perl.org/search?query=Catalyst%3A%3AView%3A%3A&mode=all">views</a>;
they can save you a lot of work.</p>
- <pre><code>script/${prefix}_create.pl -help</code></pre>
+ <pre><code>script/${prefix}_create.pl --help</code></pre>
<p>Also, be sure to check out the vast and growing
collection of <a href="http://search.cpan.org/search?query=Catalyst">plugins for Catalyst on CPAN</a>;
you are likely to find what you need there.
@@ -1743,6 +1759,8 @@
$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;
@@ -1967,8 +1985,7 @@
$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;
@@ -1998,17 +2015,6 @@
$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 )
@@ -2092,61 +2098,224 @@
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};
+}
+
+=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<Catalyst::Request/query_keywords>)
+
+=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->log_response
+
+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 log_response {
+ my $c = shift;
+
+ return unless $c->debug;
+
+ 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 log_response_status_line {
+ my ($c, $response) = @_;
+
+ $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_response_headers($headers);
+
+Hook method which can be wrapped by plugins to log the responseheaders.
+No-op in the default implementation.
+
+=cut
+
+sub log_response_headers {}
+
+=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( "Query Parameters are:\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 {
+ $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 file size are all included in
+the debug logs.
+
+=cut
+
+sub log_request_uploads {
my $c = shift;
-
- $c->engine->prepare_uploads( $c, @_ );
-
- if ( $c->debug && keys %{ $c->request->uploads } ) {
+ 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 );
}
}
$c->log->debug( "File Uploads are:\n" . $t->draw );
}
+}
+
+=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<HTTP::Headers> (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
@@ -3002,6 +3171,8 @@
sky: Arthur Bergman
+szbalint: Balint Szilakszi <szbalint at cpan.org>
+
t0m: Tomas Doran <bobtfish at bobtfish.net>
Ulf Edvinsson
Modified: trunk/libcatalyst-perl/lib/Catalyst/DispatchType/Chained.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/lib/Catalyst/DispatchType/Chained.pm?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/lib/Catalyst/DispatchType/Chained.pm (original)
+++ trunk/libcatalyst-perl/lib/Catalyst/DispatchType/Chained.pm Mon Mar 29 09:49:46 2010
@@ -105,7 +105,7 @@
if (my $cap = $curr->attributes->{CaptureArgs}) {
unshift(@parts, (("*") x $cap->[0]));
}
- if (my $pp = $curr->attributes->{PartPath}) {
+ if (my $pp = $curr->attributes->{PathPart}) {
unshift(@parts, $pp->[0])
if (defined $pp->[0] && length $pp->[0]);
}
@@ -304,7 +304,7 @@
);
}
- $action->attributes->{PartPath} = [ $part ];
+ $action->attributes->{PathPart} = [ $part ];
unshift(@{ $children->{$part} ||= [] }, $action);
@@ -358,7 +358,7 @@
unshift(@parts, splice(@captures, -$cap->[0]));
}
}
- if (my $pp = $curr->attributes->{PartPath}) {
+ if (my $pp = $curr->attributes->{PathPart}) {
unshift(@parts, $pp->[0])
if (defined($pp->[0]) && length($pp->[0]));
}
Modified: trunk/libcatalyst-perl/lib/Catalyst/DispatchType/Index.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/lib/Catalyst/DispatchType/Index.pm?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/lib/Catalyst/DispatchType/Index.pm (original)
+++ trunk/libcatalyst-perl/lib/Catalyst/DispatchType/Index.pm Mon Mar 29 09:49:46 2010
@@ -67,7 +67,7 @@
sub register {
my ( $self, $c, $action ) = @_;
- $self->_actions->{ $action->reverse } = $action;
+ $self->_actions->{ $action->reverse } = $action if $action->name eq 'index';
return 1;
}
@@ -84,7 +84,7 @@
return undef if @$captures;
- return undef unless $action->name eq 'index';
+ return undef unless exists $self->_actions->{ $action->reverse };
return "/".$action->namespace;
}
Modified: trunk/libcatalyst-perl/lib/Catalyst/Engine.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/lib/Catalyst/Engine.pm?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/lib/Catalyst/Engine.pm (original)
+++ trunk/libcatalyst-perl/lib/Catalyst/Engine.pm Mon Mar 29 09:49:46 2010
@@ -543,7 +543,7 @@
my $u = Catalyst::Request::Upload->new
(
size => $upload->{size},
- type => $headers->content_type,
+ type => scalar $headers->content_type,
headers => $headers,
tempname => $upload->{tempname},
filename => $upload->{filename},
Modified: trunk/libcatalyst-perl/lib/Catalyst/Engine/FastCGI.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/lib/Catalyst/Engine/FastCGI.pm?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/lib/Catalyst/Engine/FastCGI.pm (original)
+++ trunk/libcatalyst-perl/lib/Catalyst/Engine/FastCGI.pm Mon Mar 29 09:49:46 2010
@@ -297,7 +297,7 @@
=head3 Standalone server mode
FastCgiExternalServer /tmp/myapp.fcgi -socket /tmp/myapp.socket
- Alias /myapp/ /tmp/myapp/myapp.fcgi/
+ Alias /myapp/ /tmp/myapp.fcgi/
# Or, run at the root
Alias / /tmp/myapp.fcgi/
Modified: trunk/libcatalyst-perl/lib/Catalyst/Engine/HTTP.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/lib/Catalyst/Engine/HTTP.pm?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/lib/Catalyst/Engine/HTTP.pm (original)
+++ trunk/libcatalyst-perl/lib/Catalyst/Engine/HTTP.pm Mon Mar 29 09:49:46 2010
@@ -534,13 +534,21 @@
peeraddr => $iaddr
? ( inet_ntoa($iaddr) || '127.0.0.1' )
: '127.0.0.1',
- localname => gethostbyaddr( $localiaddr, AF_INET ) || 'localhost',
+ localname => _gethostbyaddr( $localiaddr ),
localaddr => inet_ntoa($localiaddr) || '127.0.0.1',
};
return $data;
}
+{ # If you have a crappy DNS server then these can be slow, so cache 'em
+ my %hostname_cache;
+ sub _gethostbyaddr {
+ my $ip = shift;
+ $hostname_cache{$ip} ||= gethostbyaddr( $ip, AF_INET ) || 'localhost';
+ }
+}
+
sub _inet_addr { unpack "N*", inet_aton( $_[0] ) }
=head2 options
Modified: trunk/libcatalyst-perl/lib/Catalyst/Runtime.pm
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/lib/Catalyst/Runtime.pm?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/lib/Catalyst/Runtime.pm (original)
+++ trunk/libcatalyst-perl/lib/Catalyst/Runtime.pm Mon Mar 29 09:49:46 2010
@@ -7,7 +7,7 @@
# Remember to update this in Catalyst as well!
-our $VERSION='5.80021';
+our $VERSION='5.80022';
$VERSION = eval $VERSION;
Modified: trunk/libcatalyst-perl/t/aggregate/unit_core_uri_for.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/t/aggregate/unit_core_uri_for.t?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/t/aggregate/unit_core_uri_for.t (original)
+++ trunk/libcatalyst-perl/t/aggregate/unit_core_uri_for.t Mon Mar 29 09:49:46 2010
@@ -159,6 +159,17 @@
);
}
+{
+ my $index_not_private = $dispatcher->get_action_by_path(
+ '/action/chained/argsorder/index'
+ );
+
+ is(
+ Catalyst::uri_for( $context, $index_not_private )->as_string,
+ 'http://127.0.0.1/argsorder',
+ 'Return non-DispatchType::Index path for index action with args'
+ );
+}
done_testing;
Modified: trunk/libcatalyst-perl/t/aggregate/unit_core_uri_for_action.t
URL: http://svn.debian.org/wsvn/pkg-perl/trunk/libcatalyst-perl/t/aggregate/unit_core_uri_for_action.t?rev=55006&op=diff
==============================================================================
--- trunk/libcatalyst-perl/t/aggregate/unit_core_uri_for_action.t (original)
+++ trunk/libcatalyst-perl/t/aggregate/unit_core_uri_for_action.t Mon Mar 29 09:49:46 2010
@@ -20,6 +20,8 @@
my $private_action = $dispatcher->get_action_by_path(
'/class_forward_test_method'
);
+
+warn $dispatcher->uri_for_action($private_action);
ok(!defined($dispatcher->uri_for_action($private_action)),
"Private action returns undef for URI");
More information about the Pkg-perl-cvs-commits
mailing list