package Catalyst;
+# we don't need really need this, but if we load it before MRO::Compat gets
+# loaded (via Moose and Class::MOP), we can avoid some nasty warnings
+use Class::C3;
+
use Moose;
+use Class::MOP::Object ();
extends 'Catalyst::Component';
use bytes;
use Catalyst::Exception;
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; }
-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 stack => (is => 'rw', default => sub { [] });
+has stash => (is => 'rw', default => sub { {} });
+has state => (is => 'rw', default => 0);
+has stats => (is => 'rw');
+has action => (is => 'rw');
+has counter => (is => 'rw', default => sub { {} });
+has request => (is => 'rw', default => sub { $_[0]->request_class->new({}) }, required => 1, lazy => 1);
+has response => (is => 'rw', default => sub { $_[0]->response_class->new({}) }, required => 1, lazy => 1);
has namespace => (is => 'rw');
-
-attributes->import( __PACKAGE__, \&namespace, 'lvalue' );
-
sub depth { scalar @{ shift->stack || [] }; }
+sub comp { shift->component(@_) }
-# Laziness++
-*comp = \&component;
-*req = \&request;
-*res = \&response;
+sub req {
+ # carp "the use of req() is deprecated in favour of request()";
+ my $self = shift; return $self->request(@_);
+}
+sub res {
+ # carp "the use of res() is deprecated in favour of response()";
+ my $self = shift; return $self->response(@_);
+}
# For backwards compatibility
-*finalize_output = \&finalize_body;
+sub finalize_output { shift->finalize_body(@_) };
# For statistics
our $COUNT = 1;
our $START = time;
our $RECURSION = 1000;
our $DETACH = "catalyst_detach\n";
+our $GO = "catalyst_go\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 stats_class
+ engine_class context_class request_class response_class stats_class
setup_finished/;
__PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
# Remember to update this in Catalyst::Runtime as well!
-our $VERSION = '5.7013';
+our $VERSION = '5.8000_04';
sub import {
my ( $class, @arguments ) = @_;
# callers @ISA.
return unless $class eq 'Catalyst';
- my $caller = caller(0);
+ my $caller = caller();
+ return if $caller eq 'main';
+ my $meta = Moose::Meta::Class->initialize($caller);
+ #Moose->import({ into => $caller }); #do we want to do this?
- #why does called have to ISA Catalyst and ISA Controller ?
unless ( $caller->isa('Catalyst') ) {
- no strict 'refs';
- if( $caller->can('meta') ){
- my @superclasses = ($caller->meta->superclasses, $class, 'Catalyst::Controller');
- $caller->meta->superclasses(@superclasses);
- } else {
- push @{"$caller\::ISA"}, $class, 'Catalyst::Controller';
- }
+ my @superclasses = ($meta->superclasses, $class, 'Catalyst::Controller');
+ $meta->superclasses(@superclasses);
+ }
+ unless( $meta->has_method('meta') ){
+ $meta->add_method(meta => sub { Moose::Meta::Class->initialize("${caller}") } );
}
$caller->arguments( [@arguments] );
catalyst.pl MyApp
# add models, views, controllers
- script/myapp_create.pl model MyDatabase DBIC::Schema create=dynamic dbi:SQLite:/path/to/db
+ script/myapp_create.pl model MyDatabase DBIC::Schema create=static dbi:SQLite:/path/to/db
script/myapp_create.pl view MyTemplate TT
script/myapp_create.pl controller Search
### 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
}
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
### 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 ) = @_;
environment settings override the application, with <MYAPP>_STATS having the
highest priority.
-e.g.
+e.g.
use Catalyst qw/-Stats=1/
=cut
-sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) }
+sub forward { my $c = shift; no warnings 'recursion'; $c->dispatcher->forward( $c, @_ ) }
=head2 $c->detach( $action [, \@arguments ] )
=head2 $c->detach()
-The same as C<forward>, but doesn't return to the previous action when
-processing is finished.
+The same as C<forward>, but doesn't return to the previous action when
+processing is finished.
When called with no arguments it escapes the processing chain entirely.
sub detach { my $c = shift; $c->dispatcher->detach( $c, @_ ) }
+=head2 $c->visit( $action [, \@arguments ] )
+
+=head2 $c->visit( $class, $method, [, \@arguments ] )
+
+Almost the same as C<forward>, but does a full dispatch, instead of just
+calling the new C<$action> / C<$class-E<gt>$method>. This means that C<begin>,
+C<auto> and the method you go to are called, just like a new request.
+
+C<$c-E<gt>stash> is kept unchanged.
+
+In effect, C<visit> allows you to "wrap" another action, just as it
+would have been called by dispatching from a URL, while the analogous
+C<go> allows you to transfer control to another action as if it had
+been reached directly from a URL.
+
+=cut
+
+sub visit { my $c = shift; $c->dispatcher->visit( $c, @_ ) }
+
+=head2 $c->go( $action [, \@arguments ] )
+
+=head2 $c->go( $class, $method, [, \@arguments ] )
+
+Almost the same as C<detach>, but does a full dispatch like C<visit>,
+instead of just calling the new C<$action> /
+C<$class-E<gt>$method>. This means that C<begin>, C<auto> and the
+method you visit are called, just like a new request.
+
+C<$c-E<gt>stash> is kept unchanged.
+
+=cut
+
+sub go { my $c = shift; $c->dispatcher->go( $c, @_ ) }
+
=head2 $c->response
=head2 $c->res
$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' );
around stash => sub {
my $orig = shift;
my $c = shift;
+ my $stash = $orig->($c);
if (@_) {
- my $stash = @_ > 1 ? {@_} : $_[0];
- croak('stash takes a hash or hashref') unless ref $stash;
- foreach my $key ( keys %$stash ) {
- $c->$orig()->{$key} = $stash->{$key};
+ my $new_stash = @_ > 1 ? {@_} : $_[0];
+ croak('stash takes a hash or hashref') unless ref $new_stash;
+ foreach my $key ( keys %$new_stash ) {
+ $stash->{$key} = $new_stash->{$key};
}
}
- return $c->$orig();
+
+ return $stash;
};
+
=head2 $c->error
=head2 $c->error($error, ...)
$c->error(0);
}
-
-# search via regex
-sub _comp_search {
- my ( $c, @names ) = @_;
-
- foreach my $name (@names) {
- foreach my $component ( keys %{ $c->components } ) {
- return $c->components->{$component} if $component =~ /$name/i;
- }
- }
-
- return undef;
-}
-
-# try explicit component names
-sub _comp_explicit {
- my ( $c, @names ) = @_;
-
- foreach my $try (@names) {
- return $c->components->{$try} if ( exists $c->components->{$try} );
- }
-
- return undef;
-}
-
-# like component, but try just these prefixes before regex searching,
-# and do not try to return "sort keys %{ $c->components }"
-sub _comp_prefixes {
+# search components given a name and some prefixes
+sub _comp_search_prefixes {
my ( $c, $name, @prefixes ) = @_;
-
my $appclass = ref $c || $c;
+ my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::';
- my @names = map { "${appclass}::${_}::${name}" } @prefixes;
+ # map the original component name to the sub part that we will search against
+ my %eligible = map { my $n = $_; $n =~ s{^$appclass\::[^:]+::}{}; $_ => $n; }
+ grep { /$filter/ } keys %{ $c->components };
- my $comp = $c->_comp_explicit(@names);
- return $comp if defined($comp);
- $comp = $c->_comp_search($name);
- return $comp;
-}
+ # undef for a name will return all
+ return keys %eligible if !defined $name;
-# Find possible names for a prefix
+ my $query = ref $name ? $name : qr/^$name$/i;
+ my @result = grep { $eligible{$_} =~ m{$query} } keys %eligible;
-sub _comp_names {
- my ( $c, @prefixes ) = @_;
+ return map { $c->components->{ $_ } } @result if @result;
- my $appclass = ref $c || $c;
+ # if we were given a regexp to search against, we're done.
+ return if ref $name;
- my @pre = map { "${appclass}::${_}::" } @prefixes;
+ # regexp fallback
+ $query = qr/$name/i;
+ @result = map { $c->components->{ $_ } } grep { $eligible{ $_ } =~ m{$query} } keys %eligible;
- my @names;
+ # no results? try against full names
+ if( !@result ) {
+ @result = map { $c->components->{ $_ } } grep { m{$query} } keys %eligible;
+ }
- COMPONENT: foreach my $comp ($c->component) {
- foreach my $p (@pre) {
- if ($comp =~ s/^$p//) {
- push(@names, $comp);
- next COMPONENT;
- }
- }
+ # don't warn if we didn't find any results, it just might not exist
+ if( @result ) {
+ $c->log->warn( qq(Found results for "${name}" using regexp fallback.) );
+ $c->log->warn( 'Relying on the regexp fallback behavior for component resolution is unreliable and unsafe.' );
+ $c->log->warn( 'If you really want to search, pass in a regexp as the argument.' );
}
- return @names;
+ return @result;
}
-# Return a component if only one matches.
-sub _comp_singular {
+# Find possible names for a prefix
+sub _comp_names {
my ( $c, @prefixes ) = @_;
-
my $appclass = ref $c || $c;
- my ( $comp, $rest ) =
- map { $c->_comp_search("^${appclass}::${_}::") } @prefixes;
- return $comp unless $rest;
+ my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::';
+
+ my @names = map { s{$filter}{}; $_; } $c->_comp_search_prefixes( undef, @prefixes );
+ return @names;
}
# Filter a component before returning by calling ACCEPT_CONTEXT if available
sub _filter_component {
my ( $c, $comp, @args ) = @_;
+
if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) {
return $comp->ACCEPT_CONTEXT( $c, @args );
}
- else { return $comp }
+
+ return $comp;
}
=head2 COMPONENT ACCESSORS
If the name is omitted, will return the controller for the dispatched
action.
+If you want to search for controllers, pass in a regexp as the argument.
+
+ # find all controllers that start with Foo
+ my @foo_controllers = $c->controller(qr{^Foo});
+
+
=cut
sub controller {
my ( $c, $name, @args ) = @_;
- return $c->_filter_component( $c->_comp_prefixes( $name, qw/Controller C/ ),
- @args )
- if ($name);
+
+ if( $name ) {
+ 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 );
+ }
+
return $c->component( $c->action->class );
}
Any extra arguments are directly passed to ACCEPT_CONTEXT.
-If the name is omitted, it will look for
- - a model object in $c->stash{current_model_instance}, then
+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
- check if there is only one model, and return it if that's the case.
+If you want to search for models, pass in a regexp as the argument.
+
+ # find all models that start with Foo
+ my @foo_models = $c->model(qr{^Foo});
+
=cut
sub model {
my ( $c, $name, @args ) = @_;
- return $c->_filter_component( $c->_comp_prefixes( $name, qw/Model M/ ),
- @args )
- if $name;
+
+ if( $name ) {
+ 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 );
+ }
+
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};
}
return $c->model( $c->config->{default_model} )
if $c->config->{default_model};
- return $c->_filter_component( $c->_comp_singular(qw/Model M/) );
-}
-
-=head2 $c->controllers
+ my( $comp, $rest ) = $c->_comp_search_prefixes( undef, qw/Model M/);
-Returns the available names which can be passed to $c->controller
-
-=cut
+ if( $rest ) {
+ $c->log->warn( 'Calling $c->model() will return a random model unless you specify one of:' );
+ $c->log->warn( '* $c->config->{default_model} # the name of the default model to use' );
+ $c->log->warn( '* $c->stash->{current_model} # the name of the model to use for this request' );
+ $c->log->warn( '* $c->stash->{current_model_instance} # the instance of the model to use for this request' );
+ $c->log->warn( 'NB: in version 5.80, the "random" behavior will not work at all.' );
+ }
-sub controllers {
- my ( $c ) = @_;
- return $c->_comp_names(qw/Controller C/);
+ return $c->_filter_component( $comp );
}
Any extra arguments are directly passed to ACCEPT_CONTEXT.
-If the name is omitted, it will look for
- - a view object in $c->stash{current_view_instance}, then
+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
- check if there is only one view, and return it if that's the case.
+If you want to search for views, pass in a regexp as the argument.
+
+ # find all views that start with Foo
+ my @foo_views = $c->view(qr{^Foo});
+
=cut
sub view {
my ( $c, $name, @args ) = @_;
- return $c->_filter_component( $c->_comp_prefixes( $name, qw/View V/ ),
- @args )
- if $name;
+
+ if( $name ) {
+ 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 );
+ }
+
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};
}
return $c->view( $c->config->{default_view} )
if $c->config->{default_view};
- return $c->_filter_component( $c->_comp_singular(qw/View V/) );
+
+ my( $comp, $rest ) = $c->_comp_search_prefixes( undef, qw/View V/);
+
+ if( $rest ) {
+ $c->log->warn( 'Calling $c->view() will return a random view unless you specify one of:' );
+ $c->log->warn( '* $c->config->{default_view} # the name of the default view to use' );
+ $c->log->warn( '* $c->stash->{current_view} # the name of the view to use for this request' );
+ $c->log->warn( '* $c->stash->{current_view_instance} # the instance of the view to use for this request' );
+ $c->log->warn( 'NB: in version 5.80, the "random" behavior will not work at all.' );
+ }
+
+ return $c->_filter_component( $comp );
+}
+
+=head2 $c->controllers
+
+Returns the available names which can be passed to $c->controller
+
+=cut
+
+sub controllers {
+ my ( $c ) = @_;
+ return $c->_comp_names(qw/Controller C/);
}
=head2 $c->models
class. C<< $c->controller >>, C<< $c->model >>, and C<< $c->view >>
should be used instead.
+If C<$name> is a regexp, a list of components matched against the full
+component name will be returned.
+
=cut
sub component {
- my $c = shift;
+ my ( $c, $name, @args ) = @_;
- if (@_) {
+ if( $name ) {
+ my $comps = $c->components;
- my $name = shift;
+ if( !ref $name ) {
+ # is it the exact name?
+ return $c->_filter_component( $comps->{ $name }, @args )
+ if exists $comps->{ $name };
- my $appclass = ref $c || $c;
+ # perhaps we just omitted "MyApp"?
+ my $composed = ( ref $c || $c ) . "::${name}";
+ return $c->_filter_component( $comps->{ $composed }, @args )
+ if exists $comps->{ $composed };
- my @names = (
- $name, "${appclass}::${name}",
- map { "${appclass}::${_}::${name}" }
- qw/Model M Controller C View V/
- );
+ # search all of the models, views and controllers
+ my( $comp ) = $c->_comp_search_prefixes( $name, qw/Model M Controller C View V/ );
+ return $c->_filter_component( $comp, @args ) if $comp;
+ }
+
+ # This is here so $c->comp( '::M::' ) works
+ my $query = ref $name ? $name : qr{$name}i;
+
+ my @result = grep { m{$query} } keys %{ $c->components };
+ return map { $c->_filter_component( $_, @args ) } @result if ref $name;
- my $comp = $c->_comp_explicit(@names);
- return $c->_filter_component( $comp, @_ ) if defined($comp);
+ if( $result[ 0 ] ) {
+ $c->log->warn( qq(Found results for "${name}" using regexp fallback.) );
+ $c->log->warn( 'Relying on the regexp fallback behavior for component resolution' );
+ $c->log->warn( 'is unreliable and unsafe. You have been warned' );
+ return $c->_filter_component( $result[ 0 ], @args );
+ }
- $comp = $c->_comp_search($name);
- return $c->_filter_component( $comp, @_ ) if defined($comp);
+ # I would expect to return an empty list here, but that breaks back-compat
}
+ # fallback
return sort keys %{ $c->components };
}
-
-
=head2 CLASS DATA AND HELPER CLASSES
=head2 $c->config
sub setup {
my ( $class, @arguments ) = @_;
-
$class->log->warn("Running setup twice is not a good idea.")
if ( $class->setup_finished );
EOF
}
-
+
if ( $class->debug ) {
my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins;
}
# Add our self to components, since we are also a component
- $class->components->{$class} = $class;
+ if( $class->isa('Catalyst::Controller') ){
+ $class->components->{$class} = $class;
+ }
$class->setup_actions;
$class->setup_finished(1);
}
+=head2 $c->uri_for( $action, \@captures?, @args?, \%query_values? )
+
=head2 $c->uri_for( $path, @args?, \%query_values? )
-Merges path with C<< $c->request->base >> for absolute URIs and with
-C<< $c->namespace >> for relative URIs, then returns a normalized L<URI>
-object. If any args are passed, they are added at the end of the path.
-If the last argument to C<uri_for> is a hash reference, it is assumed to
-contain GET parameter key/value pairs, which will be appended to the URI
-in standard fashion.
+=over
+
+=item $action
-Note that uri_for is destructive to the passed hashref. Subsequent calls
-with the same hashref may have unintended results.
+A Catalyst::Action object representing the Catalyst action you want to
+create a URI for. To get one for an action in the current controller,
+use C<< $c->action('someactionname') >>. To get one from different
+controller, fetch the controller using C<< $c->controller() >>, then
+call C<action_for> on it.
-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
-C<@args> is an arrayref it is treated as a list of captures to be passed
-to C<uri_for_action>.
+You can maintain the arguments captured by an action (e.g.: Regex, Chained)
+using C<< $c->req->captures >>.
+
+ # For the current action
+ $c->uri_for($c->action, $c->req->captures);
+
+ # For the Foo action in the Bar controller
+ $c->uri_for($c->controller->('Bar')->action_for('Foo'), $c->req->captures);
+
+=back
=cut
}
unshift(@args, $namespace || '');
}
-
+
# 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{(?<!/)$}{/};
if (my @keys = keys %$params) {
# somewhat lifted from URI::_query's query_form
$query = '?'.join('&', map {
+ my $val = $params->{$_};
s/([;\/?:@&=+,\$\[\]%])/$URI::Escape::escapes{$1}/go;
s/ /+/g;
my $key = $_;
- my $val = $params->{$_};
$val = '' unless defined $val;
(map {
$_ = "$_";
<p>That really depends on what <b>you</b> want to do.
We do, however, provide you with a few starting points.</p>
<p>If you want to jump right into web development with Catalyst
- you might want want to start with a tutorial.</p>
+ you might want to start with a tutorial.</p>
<pre>perldoc <a href="http://cpansearch.perl.org/dist/Catalyst-Manual/lib/Catalyst/Manual/Tutorial.pod">Catalyst::Manual::Tutorial</a></code>
</pre>
<p>Afterwards you can go on to check out a more complete look at our features.</p>
<a href="http://dev.catalyst.perl.org">Wiki</a>
</li>
<li>
- <a href="http://lists.rawmode.org/mailman/listinfo/catalyst">Mailing-List</a>
+ <a href="http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst">Mailing-List</a>
</li>
<li>
<a href="irc://irc.perl.org/catalyst">IRC channel #catalyst on irc.perl.org</a>
</li>
</ul>
<h2>In conclusion</h2>
- <p>The Catalyst team hopes you will enjoy using Catalyst as much
+ <p>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.</p>
</div>
sub dump_these {
my $c = shift;
- [ Request => $c->req ],
- [ Response => $c->res ],
+ [ Request => $c->req ],
+ [ Response => $c->res ],
[ Stash => $c->stash ],
[ Config => $c->config ];
}
$c->state(0);
if ( $c->depth >= $RECURSION ) {
- my $action = "$code";
+ my $action = $code->reverse();
$action = "/$action" unless $action =~ /->/;
- my $error = qq/Deep recursion detected calling "$action"/;
+ my $error = qq/Deep recursion detected calling "${action}"/;
$c->log->error($error);
$c->error($error);
$c->state(0);
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 ) };
+
+ eval { $c->state( $code->execute( $class, $c, @{ $c->req->args } ) || 0 ) };
$c->_stats_finish_execute( $stats_info ) if $c->use_stats and $stats_info;
-
+
my $last = pop( @{ $c->stack } );
if ( my $error = $@ ) {
- if ( !ref($error) and $error eq $DETACH ) { die $DETACH if $c->depth > 1 }
+ if ( !ref($error) and $error eq $DETACH ) {
+ die $DETACH if($c->depth > 1);
+ }
+ elsif ( !ref($error) and $error eq $GO ) {
+ die $GO if($c->depth > 0);
+ }
else {
unless ( ref $error ) {
no warnings 'uninitialized';
return if ( ( $code->name =~ /^_.*/ )
&& ( !$c->config->{show_internal_actions} ) );
- $c->counter->{"$code"}++;
+ my $action_name = $code->reverse();
+ $c->counter->{$action_name}++;
- my $action = "$code";
+ my $action = $action_name;
$action = "/$action" unless $action =~ /->/;
# determine if the call was the result of a forward
}
}
- my $uid = "$code" . $c->counter->{"$code"};
+ my $uid = $action_name . $c->counter->{$action_name};
# is this a root-level call or a forwarded call?
if ( $callsub =~ /forward$/ ) {
# forward, locate the caller
if ( my $parent = $c->stack->[-1] ) {
$c->stats->profile(
- begin => $action,
+ begin => $action,
parent => "$parent" . $c->counter->{"$parent"},
uid => $uid,
);
}
}
else {
-
+
# root-level call
$c->stats->profile(
begin => $action,
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;
$c->finalize_body;
}
-
- if ($c->use_stats) {
+
+ 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" . $c->stats->report . "\n" );
+ "Request took ${elapsed}s ($av/s)\n" . $c->stats->report . "\n" );
}
return $c->response->status;
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 $response->{_finalized_headers};
+ return if $response->finalized_headers;
# Handle redirects
if ( my $location = $response->redirect ) {
$c->log->debug(qq/Redirecting to "$location"/) if $c->debug;
$response->header( Location => $location );
- #Moose TODO: we should probably be using a predicate method here ?
- if ( !$response->body ) {
+ if ( !$response->has_body ) {
# Add a default body if none is already present
$response->body(
qq{<html><body><p>This item has moved <a href="$location">here</a>.</p></body></html>}
$c->engine->finalize_headers( $c, @_ );
# Done
- $response->{_finalized_headers} = 1;
+ $response->finalized_headers(1);
}
=head2 $c->finalize_output
my $c = $class->prepare(@arguments);
$c->dispatch;
- $status = $c->finalize;
+ $status = $c->finalize;
};
if ( my $error = $@ ) {
}
$COUNT++;
- $class->log->_flush() if $class->log->can('_flush');
+
+ if(my $coderef = $class->log->can('_flush')){
+ $class->log->$coderef();
+ }
return $status;
}
sub prepare {
my ( $class, @arguments ) = @_;
+ # XXX
+ # After the app/ctxt split, this should become an attribute based on something passed
+ # into the application.
$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 => {},
- stack => [],
- request => $class->request_class->new(
- {
- arguments => [],
- body_parameters => {},
- cookies => {},
- headers => HTTP::Headers->new,
- parameters => {},
- query_parameters => {},
- secure => 0,
- captures => [],
- uploads => {}
- }
- ),
- response => $class->response_class->new(
- {
- body => '',
- cookies => {},
- headers => HTTP::Headers->new(),
- status => 200
- }
- ),
- stash => {},
- state => 0
- }
- );
-
- $c->stats($class->stats_class->new)->enable($c->use_stats);
- if ( $c->debug ) {
- $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
- }
+
+ my $c = $class->context_class->new({});
# For on-demand data
$c->request->_context($c);
$c->response->_context($c);
+ #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->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
+ }
+
#XXX reuse coderef from can
# Allow engine to direct the prepare flow (for POE)
if ( $c->engine->can('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;
}
my $method = $c->req->method || '';
- my $path = $c->req->path || '/';
+ my $path = $c->req->path;
+ $path = '/' unless length $path;
my $address = $c->req->address || '';
$c->log->debug(qq/"$method" request for "$path" from "$address"/)
reference. Items in the array beginning with C<::> will have the
application class name prepended to them.
+All components found will also have any
+L<Devel::InnerPackage|inner packages> loaded and set up as components.
+Note, that modules which are B<not> an I<inner package> of the main
+file namespace loaded will not be instantiated as components.
+
=cut
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 ],
%$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.)
$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 };
}
Catalyst::Exception->throw(
message =>
qq/Couldn't instantiate component "$component", "COMPONENT() didn't return an object-like value"/
- ) unless eval { $instance->can( 'can' ) };
+ ) unless blessed($instance);
return $instance;
}
}
Class::MOP::load_class($dispatcher);
- #unless (Class::Inspector->loaded($dispatcher)) {
- # require Class::Inspector->filename($dispatcher);
- #}
# dispatcher instance
$class->dispatcher( $dispatcher->new );
}
if ( $ENV{MOD_PERL} ) {
-
+ my $meta = $class->Class::MOP::Object::meta();
+
# create the apache method
- {
- no strict 'refs';
- *{"$class\::apache"} = sub { shift->engine->apache };
- }
+ $meta->add_method('apache' => sub { shift->engine->apache });
my ( $software, $version ) =
$ENV{MOD_PERL} =~ /^(\S+)\/(\d+(?:[\.\_]\d+)+)/;
}
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;
$home = $env;
}
- unless ($home) {
- $home = Catalyst::Utils::home($class);
- }
+ $home ||= Catalyst::Utils::home($class);
- #I remember recently being scolded for assigning config values like this
if ($home) {
#I remember recently being scolded for assigning config values like this
$class->config->{home} ||= $home;
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->Class::MOP::Object::meta()->add_method('debug' => sub { 1 });
$class->log->debug('Debug messages enabled');
}
}
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->Class::MOP::Object::meta()->add_method('use_stats' => sub { 1 });
$class->log->debug('Statistics enabled');
}
}
-=head2 $c->registered_plugins
+=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); >>.
# 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
- Catalyst::Utils::ensure_class_loaded( $plugin );
+ Class::MOP::load_class( $plugin );
$proto->_plugins->{$plugin} = 1;
unless ($instant) {
no strict 'refs';
- if( $class->can('meta') ){
- my @superclasses = ($plugin, $class->meta->superclasses );
- $class->meta->superclasses(@superclasses);
+ if ( my $meta = $class->Class::MOP::Object::meta() ) {
+ my @superclasses = ($plugin, $meta->superclasses );
+ $meta->superclasses(@superclasses);
} else {
unshift @{"$class\::ISA"}, $plugin;
}
parsing with a config parameter.
MyApp->config->{parse_on_demand} = 1;
-
+
=head1 PROXY SUPPORT
Many production servers operate using the common double-server approach,
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.
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;
Mailing Lists:
- http://lists.rawmode.org/mailman/listinfo/catalyst
- http://lists.rawmode.org/mailman/listinfo/catalyst-dev
+ http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst
+ http://lists.scsys.co.uk/cgi-bin/mailman/listinfo/catalyst-dev
Web:
=head2 L<Catalyst::Test> - The test suite.
-=head1 CREDITS
+=head1 PROJECT FOUNDER
+
+sri: Sebastian Riedel <sri@cpan.org>
-Andy Grundman
+=head1 CONTRIBUTORS
-Andy Wardley
+abw: Andy Wardley
-Andreas Marienborg
+acme: Leon Brocard <leon@astray.com>
Andrew Bramble
Andrew Ruthven
-Arthur Bergman
+andyg: Andy Grundman <andy@hybridized.org>
-Autrijus Tang
+audreyt: Audrey Tang
-Brian Cassidy
+bricas: Brian Cassidy <bricas@cpan.org>
-Carl Franks
+Caelum: Rafael Kitover <rkitover@io.com>
-Christian Hansen
+chansen: Christian Hansen
-Christopher Hicks
+chicks: Christopher Hicks
-Dan Sully
+dkubb: Dan Kubb <dan.kubb-cpan@onautopilot.com>
-Danijel Milicevic
+Drew Taylor
-David Kamholz
+esskar: Sascha Kiefer
-David Naughton
+fireartist: Carl Franks <cfranks@cpan.org>
-Drew Taylor
+gabb: Danijel Milicevic
Gary Ashton Jones
Geoff Richards
-Jesse Sheidlower
+ilmari: Dagfinn Ilmari Mannsåker <ilmari@ilmari.org>
-Jesse Vincent
+jcamacho: Juan Camacho
Jody Belka
Johan Lindstrom
-Juan Camacho
+jon: Jon Schutz <jjschutz@cpan.org>
-Leon Brocard
+marcus: Marcus Ramberg <mramberg@cpan.org>
-Marcus Ramberg
+miyagawa: Tatsuhiko Miyagawa <miyagawa@bulknews.net>
-Matt S Trout
+mst: Matt S. Trout <mst@shadowcatsystems.co.uk>
-Robert Sedlacek
+mugwump: Sam Vilain
-Sam Vilain
+naughton: David Naughton
-Sascha Kiefer
+ningu: David Kamholz <dkamholz@cpan.org>
-Sebastian Willert
+nothingmuch: Yuval Kogman <nothingmuch@woobling.org>
-Tatsuhiko Miyagawa
+numa: Dan Sully <daniel@cpan.org>
-Ulf Edvinsson
+obra: Jesse Vincent
+
+omega: Andreas Marienborg
+
+phaylon: Robert Sedlacek <phaylon@dunkelheit.at>
-Yuval Kogman
+rafl: Florian Ragwitz <rafl@debian.org>
-=head1 AUTHOR
+sky: Arthur Bergman
-Sebastian Riedel, C<sri@oook.de>
+the_jester: Jesse Sheidlower
+
+Ulf Edvinsson
+
+willert: Sebastian Willert <willert@cpan.org>
=head1 LICENSE
=cut
+no Moose;
+
+__PACKAGE__->meta->make_immutable;
+
1;
projects / catagits/Catalyst-Runtime.git / blobdiff