package Catalyst;
-use strict;
-use base 'Catalyst::Component';
+use Moose;
+extends 'Catalyst::Component';
use bytes;
use Catalyst::Exception;
use Catalyst::Log;
use Devel::InnerPackage ();
use File::stat;
use Module::Pluggable::Object ();
-use NEXT;
use Text::SimpleTable ();
use Path::Class::Dir ();
use Path::Class::File ();
BEGIN { require 5.008001; }
-__PACKAGE__->mk_accessors(
- qw/counter request response state action stack namespace stats/
-);
+has stack => (is => 'rw');
+has stash => (is => 'rw');
+has state => (is => 'rw');
+has stats => (is => 'rw');
+has action => (is => 'rw');
+has counter => (is => 'rw');
+has request => (is => 'rw');
+has response => (is => 'rw');
+has namespace => (is => 'rw');
+
attributes->import( __PACKAGE__, \&namespace, 'lvalue' );
our $RECURSION = 1000;
our $DETACH = "catalyst_detach\n";
+#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?
__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.7008';
+our $VERSION = '5.7013';
sub import {
my ( $class, @arguments ) = @_;
my $caller = caller(0);
+ #why does called have to ISA Catalyst and ISA Controller ?
+ #Convert test suite to not use the behavior where Myapp ISA Controller
+ # after that is done we can eliminate that little mess.
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');
+ #my @superclasses = ($caller->meta->superclasses, $class);
+ $caller->meta->superclasses(@superclasses);
+ } else {
+ push @{"$caller\::ISA"}, $class, 'Catalyst::Controller';
+ #push @{"$caller\::ISA"}, $class;
+ }
}
$caller->arguments( [@arguments] );
### in lib/MyApp.pm
use Catalyst qw/-Debug/; # include plugins here as well
- ### In lib/MyApp/Controller/Root.pm (autocreated)
+ ### 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
Specifies log level.
+=head2 -Stats
+
+Enables statistics collection and reporting. You can also force this setting
+from the system environment with CATALYST_STATS or <MYAPP>_STATS. The
+environment settings override the application, with <MYAPP>_STATS having the
+highest priority.
+
+e.g.
+
+ use Catalyst qw/-Stats=1/
+
=head1 METHODS
=head2 INFORMATION ABOUT THE CURRENT REQUEST
=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;
+ 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
=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
$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} ) {
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
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;
unshift(@args, $path);
$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;
"http://www.w3.org/TR/xhtml1/DTD/xhtml1-transitional.dtd">
<html xmlns="http://www.w3.org/1999/xhtml" xml:lang="en" lang="en">
<head>
- <meta http-equiv="Content-Language" content="en" />
- <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+ <meta http-equiv="Content-Language" content="en" />
+ <meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
<title>$name on Catalyst $VERSION</title>
<style type="text/css">
body {
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 } );
}
}
- 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 );
=cut
+#Why does this exist? This is no longer safe and WILL NOT WORK.
+# it doesnt seem to be used anywhere. can we remove it?
sub _localize_fields {
my ( $c, $localized, $code ) = ( @_ );
}
# Allow engine to handle finalize flow (for POE)
- if ( $c->engine->can('finalize') ) {
- $c->engine->finalize($c);
+ my $engine = $c->engine;
+ if ( my $code = $engine->can('finalize') ) {
+ $engine->$code($c);
}
else {
$c->finalize_body;
}
- if ($c->debug) {
- my $elapsed = sprintf '%f', tv_interval($c->stats->getNodeValue);
+ if ($c->use_stats) {
+ my $elapsed = sprintf '%f', $c->stats->elapsed;
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} || '??' );
- }
- );
-
$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;
sub finalize_headers {
my $c = shift;
+ my $response = $c->response; #accessor calls can add up?
+
+ # Moose TODO: Maybe this should be an attribute too?
# Check if we already finalized headers
- return if $c->response->{_finalized_headers};
+ return if $response->{_finalized_headers};
# Handle redirects
- if ( my $location = $c->response->redirect ) {
+ if ( my $location = $response->redirect ) {
$c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
- $c->response->header( Location => $location );
-
- if ( !$c->response->body ) {
+ $response->header( Location => $location );
+
+ #Moose TODO: we should probably be using a predicate method here ?
+ if ( !$response->body ) {
# Add a default body if none is already present
- $c->response->body(
+ $response->body(
qq{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
);
}
}
# Content-Length
- if ( $c->response->body && !$c->response->content_length ) {
+ if ( $response->body && !$response->content_length ) {
# get the length from a filehandle
- if ( blessed( $c->response->body ) && $c->response->body->can('read') )
+ if ( blessed( $response->body ) && $response->body->can('read') )
{
- my $stat = stat $c->response->body;
+ my $stat = stat $response->body;
if ( $stat && $stat->size > 0 ) {
- $c->response->content_length( $stat->size );
+ $response->content_length( $stat->size );
}
else {
$c->log->warn('Serving filehandle without a content-length');
}
}
else {
- $c->response->content_length( bytes::length( $c->response->body ) );
+ # everything should be bytes at this point, but just in case
+ $response->content_length( bytes::length( $response->body ) );
}
}
# Errors
- if ( $c->response->status =~ /^(1\d\d|[23]04)$/ ) {
- $c->response->headers->remove_header("Content-Length");
- $c->response->body('');
+ if ( $response->status =~ /^(1\d\d|[23]04)$/ ) {
+ $response->headers->remove_header("Content-Length");
+ $response->body('');
}
$c->finalize_cookies;
$c->engine->finalize_headers( $c, @_ );
# Done
- $c->response->{_finalized_headers} = 1;
+ $response->{_finalized_headers} = 1;
}
=head2 $c->finalize_output
}
$COUNT++;
+ #todo: reuse coderef from can
$class->log->_flush() if $class->log->can('_flush');
return $status;
}
sub prepare {
my ( $class, @arguments ) = @_;
+ #moose todo: context_class as attr with default
$class->context_class( ref $class || $class ) unless $class->context_class;
+ #Moose TODO: if we make empty containers the defaults then that can be
+ #handled by the context class itself instead of having this here
my $c = $class->context_class->new(
{
counter => {},
}
);
+ #surely this is not the most efficient way to do things...
+ $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 );
}
# 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);
+ #XXX reuse coderef from can
# Allow engine to direct the prepare flow (for POE)
if ( $c->engine->can('prepare') ) {
$c->engine->prepare( $c, @arguments );
$c->prepare_cookies;
$c->prepare_path;
- # On-demand parsing
- $c->prepare_body unless $c->config->{parse_on_demand};
+ # 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;
+ }
}
my $method = $c->req->method || '';
sub prepare_body {
my $c = shift;
+ #Moose TODO: what is _body ??
# Do we run for the first time?
return if defined $c->request->{_body};
You have to set C<< MyApp->config->{parse_on_demand} >> to use this
directly.
+Warning: If you use read(), Catalyst will not process the body,
+so you will not be able to access POST parameters or file uploads via
+$c->request. You must handle all body parsing yourself.
+
=cut
sub read { my $c = shift; return $c->engine->read( $c, @_ ) }
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 } );
+ #Class::MOP::load_class($component);
my $module = $class->setup_component( $component );
my %modules = (
$dispatcher = 'Catalyst::Dispatcher::' . $dispatcher;
}
- if ( $ENV{CATALYST_DISPATCHER} ) {
- $dispatcher = 'Catalyst::Dispatcher::' . $ENV{CATALYST_DISPATCHER};
- }
-
- if ( $ENV{ uc($class) . '_DISPATCHER' } ) {
- $dispatcher =
- 'Catalyst::Dispatcher::' . $ENV{ uc($class) . '_DISPATCHER' };
+ if ( my $env = Catalyst::Utils::env_value( $class, 'DISPATCHER' ) ) {
+ $dispatcher = 'Catalyst::Dispatcher::' . $env;
}
unless ($dispatcher) {
$dispatcher = $class->dispatcher_class;
}
- unless (Class::Inspector->loaded($dispatcher)) {
- require Class::Inspector->filename($dispatcher);
- }
+ Class::MOP::load_class($dispatcher);
# dispatcher instance
$class->dispatcher( $dispatcher->new );
$engine = 'Catalyst::Engine::' . $engine;
}
- if ( $ENV{CATALYST_ENGINE} ) {
- $engine = 'Catalyst::Engine::' . $ENV{CATALYST_ENGINE};
- }
-
- if ( $ENV{ uc($class) . '_ENGINE' } ) {
- $engine = 'Catalyst::Engine::' . $ENV{ uc($class) . '_ENGINE' };
+ if ( my $env = Catalyst::Utils::env_value( $class, 'ENGINE' ) ) {
+ $engine = 'Catalyst::Engine::' . $env;
}
if ( $ENV{MOD_PERL} ) {
$engine = $class->engine_class;
}
- unless (Class::Inspector->loaded($engine)) {
- require Class::Inspector->filename($engine);
- }
+ Class::MOP::load_class($engine);
+ #unless (Class::Inspector->loaded($engine)) {
+ # require Class::Inspector->filename($engine);
+ #}
# check for old engines that are no longer compatible
my $old_engine;
sub setup_home {
my ( $class, $home ) = @_;
- if ( $ENV{CATALYST_HOME} ) {
- $home = $ENV{CATALYST_HOME};
+ if ( my $env = Catalyst::Utils::env_value( $class, 'HOME' ) ) {
+ $home = $env;
}
- if ( $ENV{ uc($class) . '_HOME' } ) {
- $class =~ s/::/_/g;
- $home = $ENV{ uc($class) . '_HOME' };
- }
-
- unless ($home) {
- $home = Catalyst::Utils::home($class);
- }
+ $home ||= Catalyst::Utils::home($class);
if ($home) {
+ #I remember recently being scolded for assigning config values like this
$class->config->{home} ||= $home;
$class->config->{root} ||= Path::Class::Dir->new($home)->subdir('root');
}
$class->log( Catalyst::Log->new );
}
- my $app_flag = Catalyst::Utils::class2env($class) . '_DEBUG';
-
- if (
- ( defined( $ENV{CATALYST_DEBUG} ) || defined( $ENV{$app_flag} ) )
- ? ( $ENV{CATALYST_DEBUG} || $ENV{$app_flag} )
- : $debug
- )
- {
+ my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' );
+ if ( defined($env_debug) ? $env_debug : $debug ) {
no strict 'refs';
+ #Moose todo: dying to be made a bool attribute
*{"$class\::debug"} = sub { 1 };
$class->log->debug('Debug messages enabled');
}
=cut
+=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';
+ #Moose todo: dying to be made a bool attribute
+ *{"$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
my ( $proto, $plugin, $instant ) = @_;
my $class = ref $proto || $proto;
- Catalyst::Utils::ensure_class_loaded( $plugin, { ignore_loaded => 1 } );
+ # no ignore_loaded here, the plugin may already have been
+ # defined in memory and we don't want to error on "no file" if so
+
+ Class::MOP::load_class( $plugin );
$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;
}
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 <MYAPP>_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
=head1 ON-DEMAND PARSER
The request body is usually parsed at the beginning of a request,
-but if you want to handle input yourself or speed things up a bit,
-you can enable on-demand parsing with a config parameter.
+but if you want to handle input yourself, you can enable on-demand
+parsing with a config parameter.
MyApp->config->{parse_on_demand} = 1;
Sascha Kiefer
+Sebastian Willert
+
Tatsuhiko Miyagawa
Ulf Edvinsson
projects / catagits/Catalyst-Runtime.git / blobdiff