use strict;
use base 'Catalyst::Component';
use bytes;
-use UNIVERSAL::require;
use Catalyst::Exception;
use Catalyst::Log;
use Catalyst::Request;
use Catalyst::Response;
use Catalyst::Utils;
use Catalyst::Controller;
+use Devel::InnerPackage ();
use File::stat;
+use Module::Pluggable::Object;
use NEXT;
use Text::SimpleTable;
use Path::Class::Dir;
use utf8;
use Carp qw/croak/;
+BEGIN { require 5.008001; }
+
__PACKAGE__->mk_accessors(
qw/counter request response state action stack namespace stats/
);
our $RECURSION = 1000;
our $DETACH = "catalyst_detach\n";
-require Module::Pluggable::Fast;
-
-# Helper script generation
-our $CATALYST_SCRIPT_GEN = 27;
-
__PACKAGE__->mk_classdata($_)
for qw/components arguments dispatcher engine log dispatcher_class
engine_class context_class request_class response_class setup_finished/;
__PACKAGE__->request_class('Catalyst::Request');
__PACKAGE__->response_class('Catalyst::Response');
-our $VERSION = '5.67';
+# Remember to update this in Catalyst::Runtime as well!
+
+our $VERSION = '5.70_03';
sub import {
my ( $class, @arguments ) = @_;
catalyst.pl MyApp
# add models, views, controllers
- script/myapp_create.pl model Database DBIC dbi:SQLite:/path/to/db
+ script/myapp_create.pl model Database DBIC::SchemaLoader dbi:SQLite:/path/to/db
script/myapp_create.pl view TT TT
script/myapp_create.pl controller Search
### in lib/MyApp.pm
use Catalyst qw/-Debug/; # include plugins here as well
- ### In libMyApp/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
sub details : Regex('^product/(\w+)/details$') {
my ( $self, $c ) = @_;
# extract the (\w+) from the URI
- my $product = $c->req->snippets->[0];
+ my $product = $c->req->captures->[0];
}
See L<Catalyst::Manual::Intro> for additional information.
=head2 -Debug
-Enables debug output.
+Enables debug output. You can also force this setting from the system
+environment with CATALYST_DEBUG or <MYAPP>_DEBUG. The environment settings
+override the app, with <MYAPP>_DEBUG having highest priority.
=head2 -Engine
my $c = shift;
if (@_) {
my $stash = @_ > 1 ? {@_} : $_[0];
- while ( my ( $key, $val ) = each %$stash ) {
- $c->{stash}->{$key} = $val;
+ croak('stash takes a hash or hashref') unless ref $stash;
+ foreach my $key ( keys %$stash ) {
+ $c->{stash}->{$key} = $stash->{$key};
}
}
return $c->{stash};
$c->model('Foo')->do_stuff;
If the name is omitted, it will look for a config setting 'default_model',
-or check if there is only one model, and forward to it if that's the case.
+or check if there is only one view, and return it if that's the case.
=cut
Overload to enable debug messages (same as -Debug option).
+Note that this is a static method, not an accessor and should be overloaded
+by declaring "sub debug { 1 }" in your MyApp.pm, not by calling $c->debug(1).
+
=cut
sub debug { 0 }
sub setup {
my ( $class, @arguments ) = @_;
+ $class->log->warn("Running setup twice is not a good idea.")
+ if ( $class->setup_finished );
+
unless ( $class->isa('Catalyst') ) {
Catalyst::Exception->throw(
}
}
- $class->log->warn(
- <<"EOF") if ( $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::CATALYST_SCRIPT_GEN ) );
+ eval { require Catalyst::Devel; };
+ if( !$@ && $ENV{CATALYST_SCRIPT_GEN} && ( $ENV{CATALYST_SCRIPT_GEN} < $Catalyst::Devel::CATALYST_SCRIPT_GEN ) ) {
+ $class->log->warn(<<"EOF");
You are running an old script!
Please update by running (this will overwrite existing files):
or (this will not overwrite existing files):
catalyst.pl -scripts $class
EOF
-
+ }
+
if ( $class->debug ) {
-
- my @plugins = ();
-
- {
- no strict 'refs';
- @plugins =
- map { $_ . ' ' . ( $_->VERSION || '' ) }
- grep { /^Catalyst::Plugin/ } @{"$class\::ISA"};
- }
+ my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins;
if (@plugins) {
- my $t = Text::SimpleTable->new(76);
+ my $t = Text::SimpleTable->new(74);
$t->row($_) for @plugins;
$class->log->debug( "Loaded plugins:\n" . $t->draw );
}
$class->setup_components;
if ( $class->debug ) {
- my $t = Text::SimpleTable->new( [ 65, 'Class' ], [ 8, 'Type' ] );
+ my $t = Text::SimpleTable->new( [ 63, 'Class' ], [ 8, 'Type' ] );
for my $comp ( sort keys %{ $class->components } ) {
my $type = ref $class->components->{$comp} ? 'instance' : 'class';
$t->row( $comp, $type );
it is assumed to contain GET parameter key/value pairs, which will be
appended to the URI in standard fashion.
+Instead of $path, you can also optionally pass a $action object which will
+be resolved to a path using $c->dispatcher->uri_for_action; if the first
+element of @args is an arrayref it is treated as a list of captures to be
+passed to uri_for_action.
+
=cut
sub uri_for {
my $basepath = $base->path;
$basepath =~ s/\/$//;
$basepath .= '/';
- my $namespace = $c->namespace;
+ my $namespace = $c->namespace || '';
+
+ if ( Scalar::Util::blessed($path) ) { # action object
+ my $captures = ( scalar @args && ref $args[0] eq 'ARRAY'
+ ? shift(@args)
+ : [] );
+ $path = $c->dispatcher->uri_for_action($path, $captures);
+ return undef unless defined($path);
+ }
# massage namespace, empty if absolute path
- $namespace =~ s/^\///;
+ $namespace =~ s/^\/// if $namespace;
$namespace .= '/' if $namespace;
$path ||= '';
$namespace = '' if $path =~ /^\//;
my $params =
( scalar @args && ref $args[$#args] eq 'HASH' ? pop @args : {} );
- for my $value ( values %$params ) {\r
- my $isa_ref = ref $value;\r
- if( $isa_ref and $isa_ref ne 'ARRAY' ) {\r
- croak( "Non-array reference ($isa_ref) passed to uri_for()" );\r
- }\r
- utf8::encode( $_ ) for grep { defined } $isa_ref ? @$value : $value;\r
+ for my $value ( values %$params ) {
+ my $isa_ref = ref $value;
+ if( $isa_ref and $isa_ref ne 'ARRAY' ) {
+ croak( "Non-array reference ($isa_ref) passed to uri_for()" );
+ }
+ utf8::encode( $_ ) for grep { defined } $isa_ref ? @$value : $value;
};
# join args with '/', or a blank string
text-align: left;
background-color: #ccc;
border: 1px solid #aaa;
- -moz-border-radius: 10px;
}
p, h1, h2 {
margin-left: 20px;
margin: 10px;
background-color: #fff;
border: 1px solid #aaa;
- -moz-border-radius: 10px;
}
h1 {
font-size: 0.9em;
sub dump_these {
my $c = shift;
- [ Request => $c->req ], [ Response => $c->res ], [ Stash => $c->stash ],;
+ [ Request => $c->req ],
+ [ Response => $c->res ],
+ [ Stash => $c->stash ],
+ [ Config => $c->config ];
}
=head2 $c->engine_class
return $c->state;
}
- my $stats_info = $c->_stats_start_execute( $code );
+ my $stats_info = $c->_stats_start_execute( $code ) if $c->debug;
push( @{ $c->stack }, $code );
eval { $c->state( &$code( $class, $c, @{ $c->req->args } ) || 0 ) };
- $c->_stats_finish_execute( $stats_info );
+ $c->_stats_finish_execute( $stats_info ) if $c->debug and $stats_info;
- my $last = ${ $c->stack }[-1];
- pop( @{ $c->stack } );
+ my $last = pop( @{ $c->stack } );
if ( my $error = $@ ) {
if ( $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
sub _stats_start_execute {
my ( $c, $code ) = @_;
- return unless $c->debug;
-
- my $action = "$code";
+ return if ( ( $code->name =~ /^_.*/ )
+ && ( !$c->config->{show_internal_actions} ) );
- $action = "/$action" unless $action =~ /\-\>/;
$c->counter->{"$code"}++;
+ my $action = "$code";
+ $action = "/$action" unless $action =~ /->/;
+
# determine if the call was the result of a forward
# this is done by walking up the call stack and looking for a calling
# sub of Catalyst::forward before the eval
);
$node->setUID( "$code" . $c->counter->{"$code"} );
- unless ( ( $code->name =~ /^_.*/ )
- && ( !$c->config->{show_internal_actions} ) )
- {
- # 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);
- }
- }
- else {
-
- # forward with no caller may come from a plugin
- $c->stats->addChild($node);
+ # 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);
}
}
else {
- # root-level call
+ # forward with no caller may come from a plugin
$c->stats->addChild($node);
}
}
+ else {
- my $start = [gettimeofday];
- my $elapsed = tv_interval($start);
+ # root-level call
+ $c->stats->addChild($node);
+ }
return {
- code => $code,
- elapsed => $elapsed,
- start => $start,
+ start => [gettimeofday],
node => $node,
- }
+ };
}
sub _stats_finish_execute {
my ( $c, $info ) = @_;
-
- return unless $c->debug;
-
- my ( $code, $start, $elapsed ) = @{ $info }{qw/code start elapsed/};
-
- unless ( ( $code->name =~ /^_.*/ )
- && ( !$c->config->{show_internal_actions} ) )
- {
-
- # FindByUID uses an internal die, so we save the existing error
- my $error = $@;
-
- # locate the node in the tree and update the elapsed time
- my $visitor = Tree::Simple::Visitor::FindByUID->new;
- $visitor->searchForUID( "$code" . $c->counter->{"$code"} );
- $c->stats->accept($visitor);
- if ( my $result = $visitor->getResult ) {
- my $value = $result->getNodeValue;
- $value->{elapsed} = sprintf( '%fs', $elapsed );
- $result->setNodeValue($value);
- }
-
- # restore error
- $@ = $error || undef;
- }
+ my $elapsed = tv_interval $info->{start};
+ my $value = $info->{node}->getNodeValue;
+ $value->{elapsed} = sprintf( '%fs', $elapsed );
}
=head2 $c->_localize_fields( sub { }, \%keys );
# Allow engine to handle finalize flow (for POE)
if ( $c->engine->can('finalize') ) {
- $c->engine->finalize( $c );
+ $c->engine->finalize($c);
}
else {
# Always expect worst case!
my $status = -1;
eval {
- my $stats = ( $class->debug ) ? Tree::Simple->new: q{};
-
- my $handler = sub {
+ if ($class->debug) {
+ my $start = [gettimeofday];
my $c = $class->prepare(@arguments);
- $c->stats($stats);
+ $c->stats(Tree::Simple->new);
$c->dispatch;
- return $c->finalize;
- };
+ $status = $c->finalize;
- if ( $class->debug ) {
- my $start = [gettimeofday];
- $status = &$handler;
my $elapsed = tv_interval $start;
$elapsed = sprintf '%f', $elapsed;
my $av = sprintf '%.3f',
( $elapsed == 0 ? '??' : ( 1 / $elapsed ) );
- my $t = Text::SimpleTable->new( [ 64, 'Action' ], [ 9, 'Time' ] );
+ my $t = Text::SimpleTable->new( [ 62, 'Action' ], [ 9, 'Time' ] );
- $stats->traverse(
+ $c->stats->traverse(
sub {
my $action = shift;
my $stat = $action->getNodeValue;
$class->log->info(
"Request took ${elapsed}s ($av/s)\n" . $t->draw );
}
- else { $status = &$handler }
-
+ else {
+ my $c = $class->prepare(@arguments);
+ $c->dispatch;
+ $status = $c->finalize;
+ }
};
if ( my $error = $@ ) {
parameters => {},
query_parameters => {},
secure => 0,
- snippets => [],
+ captures => [],
uploads => {}
}
),
if ( $c->debug ) {
my $secs = time - $START || 1;
my $av = sprintf '%.3f', $COUNT / $secs;
- $c->log->debug('**********************************');
- $c->log->debug("* Request $COUNT ($av/s) [$$]");
- $c->log->debug('**********************************');
+ my $time = localtime time;
+ $c->log->info("*** Request $COUNT ($av/s) [$$] [$time] ***");
$c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
}
}
my $method = $c->req->method || '';
- my $path = $c->req->path || '';
+ my $path = $c->req->path || '/';
my $address = $c->req->address || '';
$c->log->debug(qq/"$method" request for "$path" from "$address"/)
$c->prepare_uploads;
if ( $c->debug && keys %{ $c->req->body_parameters } ) {
- my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
+ 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 : '';
$c->engine->prepare_query_parameters( $c, @_ );
if ( $c->debug && keys %{ $c->request->query_parameters } ) {
- my $t = Text::SimpleTable->new( [ 37, 'Key' ], [ 36, 'Value' ] );
+ 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 : '';
if ( $c->debug && keys %{ $c->request->uploads } ) {
my $t = Text::SimpleTable->new(
- [ 12, 'Key' ],
- [ 28, 'Filename' ],
+ [ 12, 'Parameter' ],
+ [ 26, 'Filename' ],
[ 18, 'Type' ],
[ 9, 'Size' ]
);
=head2 $c->setup_components
-Sets up components.
+Sets up components. Specify a C<setup_components> config option to pass additional options
+directly to L<Module::Pluggable>. To add additional search paths, specify a key named
+C<search_extra> as an array reference. Items in the array beginning with C<::> will have the
+application class name prepended to them.
=cut
sub setup_components {
my $class = shift;
- my $callback = sub {
- my ( $component, $context ) = @_;
-
- unless ( $component->can('COMPONENT') ) {
- return $component;
+ 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 ],
+ %$config
+ );
+
+ for my $component ( sort { length $a <=> length $b } $locator->plugins ) {
+ Catalyst::Utils::ensure_class_loaded( $component );
+
+ my $module = $class->setup_component( $component );
+ my %modules = (
+ $component => $module,
+ map {
+ $_ => $class->setup_component( $_ )
+ } Devel::InnerPackage::list_packages( $component )
+ );
+
+ for my $key ( keys %modules ) {
+ $class->components->{ $key } = $modules{ $key };
}
+ }
+}
- my $suffix = Catalyst::Utils::class2classsuffix($component);
- my $config = $class->config->{$suffix} || {};
-
- my $instance;
-
- eval { $instance = $component->COMPONENT( $context, $config ); };
+=head2 $c->setup_component
- if ( my $error = $@ ) {
+=cut
- chomp $error;
+sub setup_component {
+ my( $class, $component ) = @_;
- Catalyst::Exception->throw( message =>
- qq/Couldn't instantiate component "$component", "$error"/ );
- }
+ unless ( $component->can( 'COMPONENT' ) ) {
+ return $component;
+ }
- Catalyst::Exception->throw( message =>
-qq/Couldn't instantiate component "$component", "COMPONENT() didn't return a object"/
- )
- unless ref $instance;
- return $instance;
- };
+ my $suffix = Catalyst::Utils::class2classsuffix( $component );
+ my $config = $class->config->{ $suffix } || {};
- eval "package $class;\n" . q!Module::Pluggable::Fast->import(
- name => '_catalyst_components',
- search => [
- "$class\::Controller", "$class\::C",
- "$class\::Model", "$class\::M",
- "$class\::View", "$class\::V"
- ],
- callback => $callback
- );
- !;
+ my $instance = eval { $component->COMPONENT( $class, $config ); };
if ( my $error = $@ ) {
-
chomp $error;
-
Catalyst::Exception->throw(
- message => qq/Couldn't load components "$error"/ );
+ message => qq/Couldn't instantiate component "$component", "$error"/
+ );
}
- for my $component ( $class->_catalyst_components($class) ) {
- $class->components->{ ref $component || $component } = $component;
- }
+ Catalyst::Exception->throw(
+ message =>
+ qq/Couldn't instantiate component "$component", "COMPONENT() didn't return an object-like value"/
+ ) unless eval { $instance->can( 'can' ) };
+
+ return $instance;
}
=head2 $c->setup_dispatcher
$dispatcher = $class->dispatcher_class;
}
- $dispatcher->require;
-
- if ($@) {
- Catalyst::Exception->throw(
- message => qq/Couldn't load dispatcher "$dispatcher", "$@"/ );
+ unless (Class::Inspector->loaded($dispatcher)) {
+ require Class::Inspector->filename($dispatcher);
}
# dispatcher instance
$engine = $class->engine_class;
}
- $engine->require;
-
- if ($@) {
- Catalyst::Exception->throw( message =>
-qq/Couldn't load engine "$engine" (maybe you forgot to install it?), "$@"/
- );
+ unless (Class::Inspector->loaded($engine)) {
+ require Class::Inspector->filename($engine);
}
# check for old engines that are no longer compatible
my ( $proto, $plugin, $instant ) = @_;
my $class = ref $proto || $proto;
- $plugin->require;
-
- if ( my $error = $@ ) {
- my $type = $instant ? "instant " : '';
- Catalyst::Exception->throw(
- message => qq/Couldn't load ${type}plugin "$plugin", $error/ );
+ unless (Class::Inspector->loaded($plugin)) {
+ require Class::Inspector->filename($plugin);
}
$proto->_plugins->{$plugin} = 1;
projects / catagits/Catalyst-Runtime.git / blobdiff