X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=catagits%2FCatalyst-Runtime.git;a=blobdiff_plain;f=lib%2FCatalyst.pm;h=a7519840460a3787617e17d51bf0ccaa4ace6b96;hp=21c04d8e18ae6e03604873557f0773fe44691bfc;hb=79f5d5718d885ee1c3f288159a31562f9cf5b02f;hpb=29817f46bdaaa28fb0c1471fc74084482ce6f3ee diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index 21c04d8..a751984 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -1,10 +1,14 @@ package Catalyst; use Moose; +use Moose::Meta::Class (); extends 'Catalyst::Component'; +use Moose::Util qw/find_meta/; use bytes; -use Scope::Upper (); +use B::Hooks::EndOfScope (); use Catalyst::Exception; +use Catalyst::Exception::Detach; +use Catalyst::Exception::Go; use Catalyst::Log; use Catalyst::Request; use Catalyst::Request::Upload; @@ -17,13 +21,12 @@ use Module::Pluggable::Object (); use Text::SimpleTable (); use Path::Class::Dir (); use Path::Class::File (); -use Time::HiRes qw/gettimeofday tv_interval/; use URI (); use URI::http; use URI::https; -use Scalar::Util qw/weaken/; use Tree::Simple qw/use_weak_refs/; use Tree::Simple::Visitor::FindByUID; +use Class::C3::Adopt::NEXT; use attributes; use utf8; use Carp qw/croak carp shortmess/; @@ -44,11 +47,9 @@ sub depth { scalar @{ shift->stack || [] }; } sub comp { shift->component(@_) } 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(@_); } @@ -59,14 +60,14 @@ sub finalize_output { shift->finalize_body(@_) }; our $COUNT = 1; our $START = time; our $RECURSION = 1000; -our $DETACH = "catalyst_detach\n"; -our $GO = "catalyst_go\n"; +our $DETACH = Catalyst::Exception::Detach->new; +our $GO = Catalyst::Exception::Go->new; #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'); @@ -77,7 +78,14 @@ __PACKAGE__->stats_class('Catalyst::Stats'); # Remember to update this in Catalyst::Runtime as well! -our $VERSION = '5.8000_05'; +our $VERSION = '5.80005'; + +{ + my $dev_version = $VERSION =~ /_\d{2}$/; + *_IS_DEVELOPMENT_VERSION = sub () { $dev_version }; +} + +$VERSION = eval $VERSION; sub import { my ( $class, @arguments ) = @_; @@ -88,6 +96,12 @@ sub import { my $caller = caller(); return if $caller eq 'main'; + + # Kill Adopt::NEXT warnings if we're a non-RC version + unless (_IS_DEVELOPMENT_VERSION()) { + Class::C3::Adopt::NEXT->unimport(qr/^Catalyst::/); + } + my $meta = Moose::Meta::Class->initialize($caller); #Moose->import({ into => $caller }); #do we want to do this? @@ -130,30 +144,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 @@ -161,9 +175,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 @@ -173,20 +187,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 ) = @_; @@ -259,7 +273,7 @@ MYAPP_WEB_HOME. If both variables are set, the MYAPP_HOME one will be used. =head2 -Log use Catalyst '-Log=warn,fatal,error'; - + Specifies a comma-delimited list of log levels. =head2 -Stats @@ -269,7 +283,7 @@ from the system environment with CATALYST_STATS or _STATS. The environment settings override the application, with _STATS having the highest priority. -e.g. +e.g. use Catalyst qw/-Stats=1/ @@ -340,8 +354,8 @@ sub forward { my $c = shift; no warnings 'recursion'; $c->dispatcher->forward( $ =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. @@ -349,9 +363,9 @@ 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( $action [, \@captures, \@arguments ] ) -=head2 $c->visit( $class, $method, [, \@arguments ] ) +=head2 $c->visit( $class, $method, [, \@captures, \@arguments ] ) Almost the same as C, but does a full dispatch, instead of just calling the new C<$action> / C<$class-E$method>. This means that C, @@ -375,9 +389,9 @@ been reached directly from a URL. sub visit { my $c = shift; $c->dispatcher->visit( $c, @_ ) } -=head2 $c->go( $action [, \@arguments ] ) +=head2 $c->go( $action [, \@captures, \@arguments ] ) -=head2 $c->go( $class, $method, [, \@arguments ] ) +=head2 $c->go( $class, $method, [, \@captures, \@arguments ] ) Almost the same as C, but does a full dispatch like C, instead of just calling the new C<$action> / @@ -409,7 +423,7 @@ 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' ); @@ -481,11 +495,17 @@ sub clear_errors { $c->error(0); } -# search components given a name and some prefixes sub _comp_search_prefixes { + my $c = shift; + return map $c->components->{ $_ }, $c->_comp_names_search_prefixes(@_); +} + +# search components given a name and some prefixes +sub _comp_names_search_prefixes { my ( $c, $name, @prefixes ) = @_; my $appclass = ref $c || $c; my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::'; + $filter = qr/$filter/; # Compile regex now rather than once per loop # map the original component name to the sub part that we will search against my %eligible = map { my $n = $_; $n =~ s{^$appclass\::[^:]+::}{}; $_ => $n; } @@ -497,23 +517,25 @@ sub _comp_search_prefixes { my $query = ref $name ? $name : qr/^$name$/i; my @result = grep { $eligible{$_} =~ m{$query} } keys %eligible; - return map { $c->components->{ $_ } } @result if @result; + return @result if @result; # if we were given a regexp to search against, we're done. return if ref $name; # regexp fallback $query = qr/$name/i; - @result = map { $c->components->{ $_ } } grep { $eligible{ $_ } =~ m{$query} } keys %eligible; + @result = grep { $eligible{ $_ } =~ m{$query} } keys %eligible; # no results? try against full names if( !@result ) { - @result = map { $c->components->{ $_ } } grep { m{$query} } keys %eligible; + @result = grep { m{$query} } keys %eligible; } # don't warn if we didn't find any results, it just might not exist if( @result ) { - my $msg = "Used regexp fallback for \$c->model('${name}'), which found '" . + # Disgusting hack to work out correct method name + my $warn_for = lc $prefixes[0]; + my $msg = "Used regexp fallback for \$c->${warn_for}('${name}'), which found '" . (join '", "', @result) . "'. Relying on regexp fallback behavior for " . "component resolution is unreliable and unsafe."; my $short = $result[0]; @@ -526,9 +548,9 @@ sub _comp_search_prefixes { $msg .= " You probably need to set '$short' instead of '${name}' in this " . "component's config"; } else { - $msg .= " You probably meant \$c->model('$short') instead of \$c->model{'${name}'}, " . + $msg .= " You probably meant \$c->${warn_for}('$short') instead of \$c->${warn_for}({'${name}'}), " . "but if you really wanted to search, pass in a regexp as the argument " . - "like so: \$c->model(qr/${name}/)"; + "like so: \$c->${warn_for}(qr/${name}/)"; } $c->log->warn( "${msg}$shortmess" ); } @@ -536,14 +558,16 @@ sub _comp_search_prefixes { return @result; } -# Find possible names for a prefix +# Find possible names for a prefix sub _comp_names { my ( $c, @prefixes ) = @_; my $appclass = ref $c || $c; my $filter = "^${appclass}::(" . join( '|', @prefixes ) . ')::'; - my @names = map { s{$filter}{}; $_; } $c->_comp_search_prefixes( undef, @prefixes ); + my @names = map { s{$filter}{}; $_; } + $c->_comp_names_search_prefixes( undef, @prefixes ); + return @names; } @@ -554,7 +578,7 @@ sub _filter_component { if ( eval { $comp->can('ACCEPT_CONTEXT'); } ) { return $comp->ACCEPT_CONTEXT( $c, @args ); } - + return $comp; } @@ -597,7 +621,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 @@ -620,7 +644,7 @@ sub model { } 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}; @@ -650,7 +674,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 @@ -673,7 +697,7 @@ sub view { } 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}; @@ -792,12 +816,34 @@ Returns or takes a hashref containing the application's configuration. __PACKAGE__->config( { db => 'dsn:SQLite:foo.db' } ); You can also use a C, C or C config file -like myapp.yml in your applications home directory. See +like myapp.conf in your applications home directory. See L. - --- - db: dsn:SQLite:foo.db +=head3 Cascading configuration. + +The config method is present on all Catalyst components, and configuration +will be merged when an application is started. Configuration loaded with +L takes precedence over other configuration, +followed by configuration in your top level C class. These two +configurations are merged, and then configuration data whose hash key matches a +component name is merged with configuration for that component. + +The configuration for a component is then passed to the C method when a +component is constructed. + +For example: + + MyApp->config({ 'Model::Foo' => { bar => 'baz', overrides => 'me' } }); + MyApp::Model::Foo->config({ quux => 'frob', 'overrides => 'this' }); +will mean that C receives the following data when +constructed: + + MyApp::Model::Foo->new({ + bar => 'baz', + quux => 'frob', + overrides => 'me', + }); =cut @@ -805,8 +851,8 @@ 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 ); + croak('Setting config after setup has been run is not allowed.') + if ( @_ and $c->setup_finished ); $c->$orig(@_); }; @@ -831,10 +877,23 @@ L. =head2 $c->debug -Overload to enable debug messages (same as -Debug option). +Returns 1 if debug mode is enabled, 0 otherwise. -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). +You can enable debug mode in several ways: + +=over + +=item By calling myapp_server.pl with the -d flag + +=item With the environment variables MYAPP_DEBUG, or CATALYST_DEBUG + +=item The -Debug option in your MyApp.pm + +=item By declaring C in your MyApp.pm. + +=back + +Calling C<< $c->debug(1) >> has no effect. =cut @@ -842,13 +901,11 @@ sub debug { 0 } =head2 $c->dispatcher -Returns the dispatcher instance. Stringifies to class name. See -L. +Returns the dispatcher instance. See L. =head2 $c->engine -Returns the engine instance. Stringifies to the class name. See -L. +Returns the engine instance. See L. =head2 UTILITY METHODS @@ -856,7 +913,9 @@ L. =head2 $c->path_to(@path) Merges C<@path> with C<< $c->config->{home} >> and returns a -L object. +L object. Note you can usually use this object as +a filename, but sometimes you will have to explicitly stringify it +yourself by calling the C<<->stringify>> method. For example: @@ -873,15 +932,15 @@ sub path_to { =head2 $c->plugin( $name, $class, @args ) -Helper method for plugins. It creates a classdata accessor/mutator and +Helper method for plugins. It creates a class data accessor/mutator and loads and instantiates the given class. MyApp->plugin( 'prototype', 'HTML::Prototype' ); $c->prototype->define_javascript_functions; - + B This method of adding plugins is deprecated. The ability -to add plugins like this B in a Catalyst 5.9. +to add plugins like this B in a Catalyst 5.81. Please do not use this functionality in new code. =cut @@ -889,9 +948,9 @@ Please do not use this functionality in new code. sub plugin { my ( $class, $name, $plugin, @args ) = @_; - # See block comment in t/unit_core_plugin.t - $class->log->debug(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in Catalyst 5.9/); - + # See block comment in t/unit_core_plugin.t + $class->log->warn(qq/Adding plugin using the ->plugin method is deprecated, and will be removed in Catalyst 5.81/); + $class->_register_plugin( $plugin, 1 ); eval { $plugin->import }; @@ -923,8 +982,8 @@ Catalyst> line. sub setup { my ( $class, @arguments ) = @_; - $class->log->warn("Running setup twice is not a good idea.") - if ( $class->setup_finished ); + croak('Running setup more than once') + if ( $class->setup_finished ); unless ( $class->isa('Catalyst') ) { @@ -984,7 +1043,7 @@ You are running an old script! EOF } - + if ( $class->debug ) { my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins; @@ -1010,10 +1069,11 @@ EOF } # Call plugins setup, this is stupid and evil. + # Also screws C3 badly on 5.10, hack to avoid. { no warnings qw/redefine/; local *setup = sub { }; - $class->setup; + $class->setup unless $Catalyst::__AM_RESTARTING; } # Initialize our data structure @@ -1045,16 +1105,23 @@ EOF } $class->log->_flush() if $class->log->can('_flush'); - # Make sure that the application class becomes immutable at this point, - # which ensures that it gets an inlined constructor. This means that it + # Make sure that the application class becomes immutable at this point, + # which ensures that it gets an inlined constructor. This means that it # works even if the user has added a plugin which contains a new method. # Note however that we have to do the work on scope end, so that method - # modifiers work correctly in MyApp (as you have to call setup _before_ + # modifiers work correctly in MyApp (as you have to call setup _before_ # applying modifiers). - Scope::Upper::reap(sub { + B::Hooks::EndOfScope::on_scope_end { + return if $@; my $meta = Class::MOP::get_metaclass_by_name($class); - $meta->make_immutable unless $meta->is_immutable; - }, Scope::Upper::SCOPE(1)); + if ( $meta->is_immutable && ! { $meta->immutable_options }->{inline_constructor} ) { + warn "You made your application class ($class) immutable, " + . "but did not inline the constructor.\n" + . "This will break catalyst, please pass " + . "(replace_constructor => 1) when making your class immutable.\n"; + } + $meta->make_immutable(replace_constructor => 1) unless $meta->is_immutable; + }; $class->setup_finalize; } @@ -1063,7 +1130,7 @@ EOF =head2 $app->setup_finalize A hook to attach modifiers to. -Using C< after setup => sub{}; > doesn't work, because of quirky things done for plugin setup. +Using C<< after setup => sub{}; >> doesn't work, because of quirky things done for plugin setup. Also better than C< setup_finished(); >, as that is a getter method. sub setup_finalize { @@ -1099,13 +1166,13 @@ controller, fetch the controller using C<< $c->controller() >>, then call C on it. You can maintain the arguments captured by an action (e.g.: Regex, Chained) -using C<< $c->req->captures >>. +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); + $c->uri_for($c->controller('Bar')->action_for('Foo'), $c->req->captures); =back @@ -1114,12 +1181,17 @@ using C<< $c->req->captures >>. sub uri_for { my ( $c, $path, @args ) = @_; - if ( Scalar::Util::blessed($path) ) { # action object + if ( 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); + my $action = $path; + $path = $c->dispatcher->uri_for_action($action, $captures); + if (not defined $path) { + $c->log->debug(qq/Can't find uri_for action '$action' @$captures/) + if $c->debug; + return undef; + } $path = '/' if $path eq ''; } @@ -1140,7 +1212,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 @@ -1173,6 +1245,38 @@ sub uri_for { $res; } +=head2 $c->uri_for_action( $path, \@captures?, @args?, \%query_values? ) + +=head2 $c->uri_for_action( $action, \@captures?, @args?, \%query_values? ) + +=over + +=item $path + +A private path to the Catalyst action you want to create a URI for. + +This is a shortcut for calling C<< $c->dispatcher->get_action_by_path($path) +>> and passing the resulting C<$action> and the remaining arguments to C<< +$c->uri_for >>. + +You can also pass in a Catalyst::Action object, in which case it is passed to +C<< $c->uri_for >>. + +=back + +=cut + +sub uri_for_action { + my ( $c, $path, @args ) = @_; + my $action = blessed($path) + ? $path + : $c->dispatcher->get_action_by_path($path); + unless (defined $action) { + croak "Can't find action for path '$path'"; + } + return $c->uri_for( $action, @args ); +} + =head2 $c->welcome_message Returns the Catalyst welcome HTML page. @@ -1292,7 +1396,7 @@ sub welcome_message { they can save you a lot of work.

script/${prefix}_create.pl -help

Also, be sure to check out the vast and growing - collection of plugins for Catalyst on CPAN; + collection of plugins for Catalyst on CPAN; you are likely to find what you need there.

@@ -1311,7 +1415,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.

@@ -1363,8 +1467,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 ]; } @@ -1398,18 +1502,19 @@ sub execute { my $stats_info = $c->_stats_start_execute( $code ) if $c->use_stats; push( @{ $c->stack }, $code ); - + + no warnings 'recursion'; 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 ) { + if ( blessed($error) and $error->isa('Catalyst::Exception::Detach') ) { die $DETACH if($c->depth > 1); } - elsif ( !ref($error) and $error eq $GO ) { + elsif ( blessed($error) and $error->isa('Catalyst::Exception::Go') ) { die $GO if($c->depth > 0); } else { @@ -1463,7 +1568,7 @@ sub _stats_start_execute { # forward, locate the caller if ( my $parent = $c->stack->[-1] ) { $c->stats->profile( - begin => $action, + begin => $action, parent => "$parent" . $c->counter->{"$parent"}, uid => $uid, ); @@ -1478,7 +1583,7 @@ sub _stats_start_execute { } } else { - + # root-level call $c->stats->profile( begin => $action, @@ -1505,7 +1610,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; @@ -1549,12 +1654,12 @@ sub finalize { $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; @@ -1703,7 +1808,7 @@ sub handle_request { my $c = $class->prepare(@arguments); $c->dispatch; - $status = $c->finalize; + $status = $c->finalize; }; if ( my $error = $@ ) { @@ -1712,7 +1817,7 @@ sub handle_request { } $COUNT++; - + if(my $coderef = $class->log->can('_flush')){ $class->log->$coderef(); } @@ -1733,7 +1838,7 @@ sub prepare { # 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; - + my $c = $class->context_class->new({}); # For on-demand data @@ -1743,7 +1848,7 @@ sub prepare { #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 ); + $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION ); } #XXX reuse coderef from can @@ -1762,7 +1867,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; @@ -1806,10 +1911,15 @@ sub prepare_body { $c->prepare_parameters; $c->prepare_uploads; - if ( $c->debug ) { - $c->log_parameters( - 'Body Parameters are', $c->request->body_parameters - ); + 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 ); } } @@ -1895,65 +2005,15 @@ sub prepare_query_parameters { $c->engine->prepare_query_parameters( $c, @_ ); - if ( $c->debug ) { - $c->log_parameters( - 'Query Parameters are', $c->request->query_parameters - ); - } -} - -=head2 $c->log_parameters($name, $parameters) - -Logs a hash reference of key value pairs, with a caption above the table. - -Looks like: - - [debug] Query Parameters are: - .-------------------------------------+--------------------------------------. - | Parameter | Value | - +-------------------------------------+--------------------------------------+ - | search | Moose | - | searchtype | modules | - '-------------------------------------+--------------------------------------' - -If there are query parameters you don't want to display in this output, such -as passwords or other sensitive input, you can configure your application to -redact those parameters: - - C<< MyApp->config->{Debug}->{redact_parameters} = [ 'password' ] >> - -In that case, the output will look like: - - [debug] Query Parameters are: - .-------------------------------------+--------------------------------------. - | Parameter | Value | - +-------------------------------------+--------------------------------------+ - | password | (redacted by config) | - | username | some_user | - '-------------------------------------+--------------------------------------' - -=cut - -sub log_parameters { - my ( $c, $name, $parameters ) = @_; - - my $skip = $c->config->{Debug}->{redact_parameters}; - if ( - ( not defined $skip or ref $skip eq 'ARRAY' ) - && keys %{ $parameters } - ) { - my $t = Text::SimpleTable->new( - [ 35, 'Parameter' ], [ 36, 'Value' ] ); - my %skip_params = map { $_ => $_ } @{ $skip || [] }; - for my $key ( sort keys %$parameters ) { - my $param = $parameters->{$key}; + 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}; my $value = defined($param) ? $param : ''; - $value = '(redacted by config)' if exists $skip_params{$key}; - $t->row( $key, ref $value eq 'ARRAY' ? ( join ', ', @$value ) : $value ); } - $c->log->debug( "$name:\n" . $t->draw ); + $c->log->debug( "Query Parameters are:\n" . $t->draw ); } } @@ -2066,7 +2126,7 @@ search paths, specify a key named C as an array reference. Items in the array beginning with C<::> will have the application class name prepended to them. -All components found will also have any +All components found will also have any L loaded and set up as components. Note, that modules which are B an I of the main file namespace loaded will not be instantiated as components. @@ -2079,9 +2139,9 @@ 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 @@ -2089,7 +2149,12 @@ sub setup_components { my @comps = sort { length $a <=> length $b } $locator->plugins; my %comps = map { $_ => 1 } @comps; - + + my $deprecated_component_names = grep { /::[CMV]::/ } @comps; + $class->log->warn(qq{Your application is using the deprecated ::[MVC]:: type naming scheme.\n}. + qq{Please switch your class names to ::Model::, ::View:: and ::Controller: as appropriate.\n} + ) if $deprecated_component_names; + for my $component ( @comps ) { # We pass ignore_loaded here so that overlay files for (e.g.) @@ -2104,11 +2169,11 @@ sub setup_components { $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 }; } @@ -2119,6 +2184,14 @@ sub setup_components { =cut +sub _controller_init_base_classes { + my ($app_class, $component) = @_; + foreach my $class ( reverse @{ mro::get_linear_isa($component) } ) { + Moose::Meta::Class->initialize( $class ) + unless find_meta($class); + } +} + sub setup_component { my( $class, $component ) = @_; @@ -2126,6 +2199,14 @@ sub setup_component { return $component; } + # FIXME - Ugly, ugly hack to ensure the we force initialize non-moose base classes + # nearest to Catalyst::Controller first, no matter what order stuff happens + # to be loaded. There are TODO tests in Moose for this, see + # f2391d17574eff81d911b97be15ea51080500003 + if ($component->isa('Catalyst::Controller')) { + $class->_controller_init_base_classes($component); + } + my $suffix = Catalyst::Utils::class2classsuffix( $component ); my $config = $class->config->{ $suffix } || {}; @@ -2138,11 +2219,16 @@ sub setup_component { ); } - Catalyst::Exception->throw( - message => - qq/Couldn't instantiate component "$component", "COMPONENT() didn't return an object-like value"/ - ) unless blessed($instance); - + unless (blessed $instance) { + my $metaclass = Moose::Util::find_meta($component); + my $method_meta = $metaclass->find_method_by_name('COMPONENT'); + my $component_method_from = $method_meta->associated_metaclass->name; + my $value = defined($instance) ? $instance : 'undef'; + Catalyst::Exception->throw( + message => + qq/Couldn't instantiate component "$component", COMPONENT() method (from $component_method_from) didn't return an object-like value (value was $value)./ + ); + } return $instance; } @@ -2192,7 +2278,7 @@ sub setup_engine { if ( $ENV{MOD_PERL} ) { my $meta = Class::MOP::get_metaclass_by_name($class); - + # create the apache method $meta->add_method('apache' => sub { shift->engine->apache }); @@ -2316,7 +2402,7 @@ sub setup_home { Sets up log by instantiating a L object and passing it to C. Pass in a comma-delimited list of levels to set the log to. - + This method also installs a C method that returns a true value into the catalyst subclass if the "debug" level is passed in the comma-delimited list, or if the C<$CATALYST_DEBUG> environment variable is set to a true value. @@ -2333,14 +2419,19 @@ sub setup_log { $levels ||= ''; $levels =~ s/^\s+//; $levels =~ s/\s+$//; - my %levels = map { $_ => 1 } split /\s*,\s*/, $levels || ''; - + my %levels = map { $_ => 1 } split /\s*,\s*/, $levels; + + my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' ); + if ( defined $env_debug ) { + $levels{debug} = 1 if $env_debug; # Ugly! + delete($levels{debug}) unless $env_debug; + } + unless ( $class->log ) { $class->log( Catalyst::Log->new(keys %levels) ); } - my $env_debug = Catalyst::Utils::env_value( $class, 'DEBUG' ); - if ( defined($env_debug) or $levels{debug} ) { + if ( $levels{debug} ) { Class::MOP::get_metaclass_by_name($class)->add_method('debug' => sub { 1 }); $class->log->debug('Debug messages enabled'); } @@ -2371,7 +2462,7 @@ sub setup_stats { } -=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); >>. @@ -2400,9 +2491,6 @@ the plugin name does not begin with C. my ( $proto, $plugin, $instant ) = @_; my $class = ref $proto || $proto; - # 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; @@ -2423,14 +2511,26 @@ the plugin name does not begin with C. $class->_plugins( {} ) unless $class->_plugins; $plugins ||= []; - for my $plugin ( reverse @$plugins ) { + + my @plugins = Catalyst::Utils::resolve_namespace($class . '::Plugin', 'Catalyst::Plugin', @$plugins); - unless ( $plugin =~ s/\A\+// ) { - $plugin = "Catalyst::Plugin::$plugin"; - } + for my $plugin ( reverse @plugins ) { + Class::MOP::load_class($plugin); + my $meta = find_meta($plugin); + next if $meta && $meta->isa('Moose::Meta::Role'); $class->_register_plugin($plugin); } + + my @roles = + map { $_->name } + grep { $_ && blessed($_) && $_->isa('Moose::Meta::Role') } + map { find_meta($_) } + @plugins; + + Moose::Util::apply_all_roles( + $class => @roles + ) if @roles; } } @@ -2449,8 +2549,8 @@ 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). +Note that this is a static method, not an accessor and should be overridden +by declaring C in your MyApp.pm, not by calling C<< $c->use_stats(1) >>. =cut @@ -2508,7 +2608,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, @@ -2522,9 +2622,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. @@ -2536,7 +2636,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; @@ -2610,8 +2710,6 @@ audreyt: Audrey Tang bricas: Brian Cassidy -Byron Young - Caelum: Rafael Kitover chansen: Christian Hansen @@ -2624,6 +2722,8 @@ dkubb: Dan Kubb Drew Taylor +dwc: Daniel Westermann-Clark + esskar: Sascha Kiefer fireartist: Carl Franks @@ -2672,6 +2772,8 @@ phaylon: Robert Sedlacek rafl: Florian Ragwitz +random: Roland Lammel + sky: Arthur Bergman the_jester: Jesse Sheidlower @@ -2684,7 +2786,7 @@ willert: Sebastian Willert =head1 LICENSE -This library is free software, you can redistribute it and/or modify it under +This library is free software. You can redistribute it and/or modify it under the same terms as Perl itself. =cut