X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst.pm;h=045f99292ce988a75c7d7b88417af38fca3bc297;hp=ddc91738eea88a72730213f8d01647c6d750bba6;hb=2361ed675dadcf78697c63b6ec89456c5c3c18dc;hpb=b7d5aed1805fb52ad8bb3709042d5c6b4f4aecef diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index ddc9173..045f992 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -1,7 +1,7 @@ package Catalyst; -use strict; -use base 'Catalyst::Component'; +use Moose; +extends 'Catalyst::Component'; use bytes; use Catalyst::Exception; use Catalyst::Log; @@ -31,7 +31,7 @@ use Carp qw/croak carp/; BEGIN { require 5.008001; } __PACKAGE__->mk_accessors( - qw/counter request response state action stack namespace stats/ + qw/counter request response state action stack namespace stats stash/ ); attributes->import( __PACKAGE__, \&namespace, 'lvalue' ); @@ -54,16 +54,18 @@ our $DETACH = "catalyst_detach\n"; __PACKAGE__->mk_classdata($_) for qw/components arguments dispatcher engine log dispatcher_class - engine_class context_class request_class response_class setup_finished/; + engine_class context_class request_class response_class stats_class + setup_finished/; __PACKAGE__->dispatcher_class('Catalyst::Dispatcher'); __PACKAGE__->engine_class('Catalyst::Engine::CGI'); __PACKAGE__->request_class('Catalyst::Request'); __PACKAGE__->response_class('Catalyst::Response'); +__PACKAGE__->stats_class('Catalyst::Stats'); # Remember to update this in Catalyst::Runtime as well! -our $VERSION = '5.7011'; +our $VERSION = '5.7013'; sub import { my ( $class, @arguments ) = @_; @@ -76,7 +78,12 @@ sub import { unless ( $caller->isa('Catalyst') ) { no strict 'refs'; - push @{"$caller\::ISA"}, $class, 'Catalyst::Controller'; + if( $caller->can('meta') ){ + my @superclasses = ($caller->meta->superclasses, $class, 'Catalyst::Controller'); + $caller->meta->superclasses(@superclasses); + } else { + push @{"$caller\::ISA"}, $class, 'Catalyst::Controller'; + } } $caller->arguments( [@arguments] ); @@ -110,30 +117,30 @@ documentation and tutorials. ### in lib/MyApp.pm use Catalyst qw/-Debug/; # include plugins here as well - + ### In lib/MyApp/Controller/Root.pm (autocreated) sub foo : Global { # called for /foo, /foo/1, /foo/1/2, etc. my ( $self, $c, @args ) = @_; # args are qw/1 2/ for /foo/1/2 $c->stash->{template} = 'foo.tt'; # set the template # lookup something from db -- stash vars are passed to TT - $c->stash->{data} = + $c->stash->{data} = $c->model('Database::Foo')->search( { country => $args[0] } ); if ( $c->req->params->{bar} ) { # access GET or POST parameters $c->forward( 'bar' ); # process another action - # do something else after forward returns + # do something else after forward returns } } - + # The foo.tt TT template can use the stash data from the database [% WHILE (item = data.next) %] [% item.foo %] [% END %] - + # called for /bar/of/soap, /bar/of/soap/10, etc. sub bar : Path('/bar/of/soap') { ... } # called for all actions, from the top-most controller downwards - sub auto : Private { + sub auto : Private { my ( $self, $c ) = @_; if ( !$c->user_exists ) { # Catalyst::Plugin::Authentication $c->res->redirect( '/login' ); # require login @@ -141,9 +148,9 @@ documentation and tutorials. } return 1; # success; carry on to next action } - + # called after all actions are finished - sub end : Private { + sub end : Private { my ( $self, $c ) = @_; if ( scalar @{ $c->error } ) { ... } # handle errors return if $c->res->body; # already have a response @@ -153,20 +160,20 @@ documentation and tutorials. ### in MyApp/Controller/Foo.pm # called for /foo/bar sub bar : Local { ... } - + # called for /blargle sub blargle : Global { ... } - + # an index action matches /foo, but not /foo/1, etc. sub index : Private { ... } - + ### in MyApp/Controller/Foo/Bar.pm # called for /foo/bar/baz sub baz : Local { ... } - + # first Root auto is called, then Foo auto, then this sub auto : Private { ... } - + # powerful regular expression paths are also possible sub details : Regex('^product/(\w+)/details$') { my ( $self, $c ) = @_; @@ -240,6 +247,17 @@ MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used. Specifies log level. +=head2 -Stats + +Enables statistics collection and reporting. You can also force this setting +from the system environment with CATALYST_STATS or _STATS. The +environment settings override the application, with _STATS having the +highest priority. + +e.g. + + use Catalyst qw/-Stats=1/ + =head1 METHODS =head2 INFORMATION ABOUT THE CURRENT REQUEST @@ -307,8 +325,8 @@ sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) } =head2 $c->detach() -The same as C, but doesn't return to the previous action when -processing is finished. +The same as C, but doesn't return to the previous action when +processing is finished. When called with no arguments it escapes the processing chain entirely. @@ -335,23 +353,24 @@ Catalyst). $c->stash->{foo} = $bar; $c->stash( { moose => 'majestic', qux => 0 } ); $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref - + # stash is automatically passed to the view for use in a template $c->forward( 'MyApp::View::TT' ); =cut -sub stash { +around stash => sub { + my $orig = shift; my $c = shift; if (@_) { my $stash = @_ > 1 ? {@_} : $_[0]; croak('stash takes a hash or hashref') unless ref $stash; foreach my $key ( keys %$stash ) { - $c->{stash}->{$key} = $stash->{$key}; + $c->$orig()->{$key} = $stash->{$key}; } } - return $c->{stash}; -} + return $c->$orig(); +}; =head2 $c->error @@ -443,7 +462,7 @@ sub _comp_prefixes { return $comp; } -# Find possible names for a prefix +# Find possible names for a prefix sub _comp_names { my ( $c, @prefixes ) = @_; @@ -515,7 +534,7 @@ Gets a L instance by name. Any extra arguments are directly passed to ACCEPT_CONTEXT. -If the name is omitted, it will look for +If the name is omitted, it will look for - a model object in $c->stash{current_model_instance}, then - a model name in $c->stash->{current_model}, then - a config setting 'default_model', or @@ -529,7 +548,7 @@ sub model { @args ) if $name; if (ref $c) { - return $c->stash->{current_model_instance} + return $c->stash->{current_model_instance} if $c->stash->{current_model_instance}; return $c->model( $c->stash->{current_model} ) if $c->stash->{current_model}; @@ -560,7 +579,7 @@ Gets a L instance by name. Any extra arguments are directly passed to ACCEPT_CONTEXT. -If the name is omitted, it will look for +If the name is omitted, it will look for - a view object in $c->stash{current_view_instance}, then - a view name in $c->stash->{current_view}, then - a config setting 'default_view', or @@ -574,7 +593,7 @@ sub view { @args ) if $name; if (ref $c) { - return $c->stash->{current_view_instance} + return $c->stash->{current_view_instance} if $c->stash->{current_view_instance}; return $c->view( $c->stash->{current_view} ) if $c->stash->{current_view}; @@ -663,14 +682,15 @@ L. =cut -sub config { +around config => sub { + my $orig = shift; my $c = shift; $c->log->warn("Setting config after setup has been run is not a good idea.") if ( @_ and $c->setup_finished ); - $c->NEXT::config(@_); -} + $c->$orig(@_); +}; =head2 $c->log @@ -813,6 +833,7 @@ sub setup { $class->setup_plugins( delete $flags->{plugins} ); $class->setup_dispatcher( delete $flags->{dispatcher} ); $class->setup_engine( delete $flags->{engine} ); + $class->setup_stats( delete $flags->{stats} ); for my $flag ( sort keys %{$flags} ) { @@ -837,7 +858,7 @@ You are running an old script! EOF } - + if ( $class->debug ) { my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins; @@ -906,6 +927,9 @@ If the last argument to C is a hash reference, it is assumed to contain GET parameter key/value pairs, which will be appended to the URI in standard fashion. +Note that uri_for is destructive to the passed hashref. Subsequent calls +with the same hashref may have unintended results. + Instead of C<$path>, you can also optionally pass a C<$action> object which will be resolved to a path using C<< $c->dispatcher->uri_for_action >>; if the first element of @@ -943,7 +967,7 @@ sub uri_for { } unshift(@args, $namespace || ''); } - + # join args with '/', or a blank string my $args = join('/', grep { defined($_) } @args); $args =~ s/\?/%3F/g; # STUPID STUPID SPECIAL CASE @@ -964,7 +988,7 @@ sub uri_for { $val = '' unless defined $val; (map { $_ = "$_"; - utf8::encode( $_ ); + utf8::encode( $_ ) if utf8::is_utf8($_); # using the URI::Escape pattern here so utf8 chars survive s/([^A-Za-z0-9\-_.!~*'() ])/$URI::Escape::escapes{$1}/go; s/ /+/g; @@ -1114,7 +1138,7 @@ sub welcome_message {

In conclusion

-

The Catalyst team hopes you will enjoy using Catalyst as much +

The Catalyst team hopes you will enjoy using Catalyst as much as we enjoyed making it. Please contact us if you have ideas for improvement or other feedback.

@@ -1166,8 +1190,8 @@ that will be dumped on the error page in debug mode. sub dump_these { my $c = shift; - [ Request => $c->req ], - [ Response => $c->res ], + [ Request => $c->req ], + [ Response => $c->res ], [ Stash => $c->stash ], [ Config => $c->config ]; } @@ -1198,14 +1222,14 @@ sub execute { return $c->state; } - my $stats_info = $c->_stats_start_execute( $code ) if $c->debug; + my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats; push( @{ $c->stack }, $code ); - + eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) }; - $c->_stats_finish_execute( $stats_info ) if $c->debug and $stats_info; - + $c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info; + my $last = pop( @{ $c->stack } ); if ( my $error = $@ ) { @@ -1252,51 +1276,43 @@ sub _stats_start_execute { } } - my $node = Tree::Simple->new( - { - action => $action, - elapsed => undef, # to be filled in later - comment => "", - } - ); - $node->setUID( "$code" . $c->counter->{"$code"} ); + my $uid = "$code" . $c->counter->{"$code"}; # is this a root-level call or a forwarded call? if ( $callsub =~ /forward$/ ) { # forward, locate the caller if ( my $parent = $c->stack->[-1] ) { - my $visitor = Tree::Simple::Visitor::FindByUID->new; - $visitor->searchForUID( - "$parent" . $c->counter->{"$parent"} ); - $c->stats->accept($visitor); - if ( my $result = $visitor->getResult ) { - $result->addChild($node); - } + $c->stats->profile( + begin => $action, + parent => "$parent" . $c->counter->{"$parent"}, + uid => $uid, + ); } else { # forward with no caller may come from a plugin - $c->stats->addChild($node); + $c->stats->profile( + begin => $action, + uid => $uid, + ); } } else { # root-level call - $c->stats->addChild($node); + $c->stats->profile( + begin => $action, + uid => $uid, + ); } + return $action; - return { - start => [gettimeofday], - node => $node, - }; } sub _stats_finish_execute { my ( $c, $info ) = @_; - my $elapsed = tv_interval $info->{start}; - my $value = $info->{node}->getNodeValue; - $value->{elapsed} = sprintf( '%fs', $elapsed ); + $c->stats->profile( end => $info ); } =head2 $c->_localize_fields( sub { }, \%keys ); @@ -1308,7 +1324,7 @@ sub _localize_fields { my $request = delete $localized->{request} || {}; my $response = delete $localized->{response} || {}; - + local @{ $c }{ keys %$localized } = values %$localized; local @{ $c->request }{ keys %$request } = values %$request; local @{ $c->response }{ keys %$response } = values %$response; @@ -1351,23 +1367,12 @@ sub finalize { $c->finalize_body; } - - if ($c->debug) { - my $elapsed = sprintf '%f', tv_interval($c->stats->getNodeValue); - my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed; - - my $t = Text::SimpleTable->new( [ 62, 'Action' ], [ 9, 'Time' ] ); - $c->stats->traverse( - sub { - my $action = shift; - my $stat = $action->getNodeValue; - $t->row( ( q{ } x $action->getDepth ) . $stat->{action} . $stat->{comment}, - $stat->{elapsed} || '??' ); - } - ); + if ($c->use_stats) { + my $elapsed = sprintf '%f', $c->stats->elapsed; + my $av = $elapsed == 0 ? '??' : sprintf '%.3f', 1 / $elapsed; $c->log->info( - "Request took ${elapsed}s ($av/s)\n" . $t->draw . "\n" ); + "Request took ${elapsed}s ($av/s)\n" . $c->stats->report . "\n" ); } return $c->response->status; @@ -1413,7 +1418,7 @@ sub finalize_headers { if ( my $location = $c->response->redirect ) { $c->log->debug(qq/Redirecting to "$location"/) if $c->debug; $c->response->header( Location => $location ); - + if ( !$c->response->body ) { # Add a default body if none is already present $c->response->body( @@ -1437,6 +1442,7 @@ sub finalize_headers { } } else { + # everything should be bytes at this point, but just in case $c->response->content_length( bytes::length( $c->response->body ) ); } } @@ -1513,7 +1519,7 @@ sub handle_request { my $c = $class->prepare(@arguments); $c->dispatch; - $status = $c->finalize; + $status = $c->finalize; }; if ( my $error = $@ ) { @@ -1567,16 +1573,14 @@ sub prepare { } ); + $c->stats($class->stats_class->new)->enable($c->use_stats); if ( $c->debug ) { - $c->stats(Tree::Simple->new([gettimeofday])); - $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION ); + $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION ); } # For on-demand data - $c->request->{_context} = $c; - $c->response->{_context} = $c; - weaken( $c->request->{_context} ); - weaken( $c->response->{_context} ); + $c->request->_context($c); + $c->response->_context($c); # Allow engine to direct the prepare flow (for POE) if ( $c->engine->can('prepare') ) { @@ -1593,7 +1597,7 @@ sub prepare { # Prepare the body for reading, either by prepare_body # or the user, if they are using $c->read $c->prepare_read; - + # Parse the body unless the user wants it on-demand unless ( $c->config->{parse_on_demand} ) { $c->prepare_body; @@ -1860,36 +1864,36 @@ sub setup_components { my @paths = qw( ::Controller ::C ::Model ::M ::View ::V ); my $config = $class->config->{ setup_components }; my $extra = delete $config->{ search_extra } || []; - + push @paths, @$extra; - + my $locator = Module::Pluggable::Object->new( search_path => [ map { s/^(?=::)/$class/; $_; } @paths ], - except => qr/\.#/, %$config ); my @comps = sort { length $a <=> length $b } $locator->plugins; my %comps = map { $_ => 1 } @comps; - + for my $component ( @comps ) { # We pass ignore_loaded here so that overlay files for (e.g.) # Model::DBI::Schema sub-classes are loaded - if it's in @comps # we know M::P::O found a file on disk so this is safe - Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } ); + #Catalyst::Utils::ensure_class_loaded( $component, { ignore_loaded => 1 } ); + Class::MOP::load_class($component); my $module = $class->setup_component( $component ); my %modules = ( $component => $module, map { $_ => $class->setup_component( $_ ) - } grep { + } grep { not exists $comps{$_} } Devel::InnerPackage::list_packages( $component ) ); - + for my $key ( keys %modules ) { $class->components->{ $key } = $modules{ $key }; } @@ -2126,7 +2130,27 @@ Sets up plugins. =cut -=head2 $c->registered_plugins +=head2 $c->setup_stats + +Sets up timing statistics class. + +=cut + +sub setup_stats { + my ( $class, $stats ) = @_; + + Catalyst::Utils::ensure_class_loaded($class->stats_class); + + my $env = Catalyst::Utils::env_value( $class, 'STATS' ); + if ( defined($env) ? $env : ($stats || $class->debug ) ) { + no strict 'refs'; + *{"$class\::use_stats"} = sub { 1 }; + $class->log->debug('Statistics enabled'); + } +} + + +=head2 $c->registered_plugins Returns a sorted list of the plugins which have either been stated in the import list or which have been added via C<< MyApp->plugin(@args); >>. @@ -2163,7 +2187,12 @@ the plugin name does not begin with C. $proto->_plugins->{$plugin} = 1; unless ($instant) { no strict 'refs'; - unshift @{"$class\::ISA"}, $plugin; + if( $class->can('meta') ){ + my @superclasses = ($plugin, $class->meta->superclasses ); + $class->meta->superclasses(@superclasses); + } else { + unshift @{"$class\::ISA"}, $plugin; + } } return $class; } @@ -2189,6 +2218,24 @@ the plugin name does not begin with C. Returns an arrayref of the internal execution stack (actions that are currently executing). +=head2 $c->stats_class + +Returns or sets the stats (timing statistics) class. + +=head2 $c->use_stats + +Returns 1 when stats collection is enabled. Stats collection is enabled +when the -Stats options is set, debug is on or when the _STATS +environment variable is set. + +Note that this is a static method, not an accessor and should be overloaded +by declaring "sub use_stats { 1 }" in your MyApp.pm, not by calling $c->use_stats(1). + +=cut + +sub use_stats { 0 } + + =head2 $c->write( $data ) Writes $data to the output stream. When using this method directly, you @@ -2240,7 +2287,7 @@ but if you want to handle input yourself, you can enable on-demand parsing with a config parameter. MyApp->config->{parse_on_demand} = 1; - + =head1 PROXY SUPPORT Many production servers operate using the common double-server approach, @@ -2254,9 +2301,9 @@ Catalyst will automatically detect this situation when you are running the frontend and backend servers on the same machine. The following changes are made to the request. - $c->req->address is set to the user's real IP address, as read from + $c->req->address is set to the user's real IP address, as read from the HTTP X-Forwarded-For header. - + The host value for $c->req->base and $c->req->uri is set to the real host, as read from the HTTP X-Forwarded-Host header. @@ -2268,7 +2315,7 @@ configuration option to tell Catalyst to read the proxied data from the headers. MyApp->config->{using_frontend_proxy} = 1; - + If you do not wish to use the proxy support at all, you may set: MyApp->config->{ignore_frontend_proxy} = 1; @@ -2382,6 +2429,8 @@ Sam Vilain Sascha Kiefer +Sebastian Willert + Tatsuhiko Miyagawa Ulf Edvinsson