From: Guillermo Roditi Date: Mon, 23 Jun 2008 21:00:04 +0000 (+0000) Subject: some tests fail and some things are ugly, but i think its a small step forward X-Git-Tag: 5.8000_03~118 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a7caa492274a184c77ec32af58b2dc6db7295650;p=catagits%2FCatalyst-Runtime.git some tests fail and some things are ugly, but i think its a small step forward r16998@martha (orig r7511): groditi | 2008-03-17 15:41:17 -0400 --- diff --git a/Makefile.PL b/Makefile.PL index ab5e7c6..bf4ab7f 100644 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,11 +1,13 @@ use inc::Module::Install 0.64; -use 5.008001; +use 5.008001; perl_version '5.8.1'; name 'Catalyst-Runtime'; all_from 'lib/Catalyst/Runtime.pm'; +requires 'MooseX::Emulate::Class::Accessor::Fast'; + requires 'perl' => '5.8.1'; requires 'Carp'; requires 'Class::Accessor::Fast'; @@ -38,7 +40,7 @@ if (-e 'inc/.author') { build_requires 'Test::Pod' => 1.14; build_requires 'Test::Pod::Coverage' => 1.04; - if ($^O eq 'darwin') { + if ($^O eq 'darwin') { my $osx_ver = `/usr/bin/sw_vers -productVersion`; chomp $osx_ver; @@ -48,7 +50,7 @@ if (-e 'inc/.author') { makemaker_args(dist => { PREOP => qq{\@if [ "\$\$$attr" != "true" ]; then}. qq{ echo "You must set the ENV variable $attr to true,"; }. - ' echo "to avoid getting resource forks in your dist."; exit 255; fi' }); + ' echo "to avoid getting resource forks in your dist."; exit 255; fi' }); } } @@ -68,7 +70,7 @@ print <<"EOF"; perl -MCPANPLUS -e 'install Catalyst::Devel' # or perl -MCPAN -e 'install Catalyst::Devel' - To get some commonly used plugins, as well as the TT view and DBIC + To get some commonly used plugins, as well as the TT view and DBIC model, install Task::Catalyst in the same way. Have fun! diff --git a/lib/Catalyst.pm b/lib/Catalyst.pm index 9183864..ad8086c 100644 --- a/lib/Catalyst.pm +++ b/lib/Catalyst.pm @@ -1,7 +1,7 @@ package Catalyst; -use strict; -use base 'Catalyst::Component'; +use Moose; +extends 'Catalyst::Component'; use bytes; use Catalyst::Exception; use Catalyst::Log; @@ -31,7 +31,7 @@ use Carp qw/croak carp/; BEGIN { require 5.008001; } __PACKAGE__->mk_accessors( - qw/counter request response state action stack namespace stats/ + qw/counter request response state action stack namespace stats stash/ ); attributes->import( __PACKAGE__, \&namespace, 'lvalue' ); @@ -54,7 +54,7 @@ our $DETACH = "catalyst_detach\n"; __PACKAGE__->mk_classdata($_) for qw/components arguments dispatcher engine log dispatcher_class - engine_class context_class request_class response_class stats_class + engine_class context_class request_class response_class stats_class setup_finished/; __PACKAGE__->dispatcher_class('Catalyst::Dispatcher'); @@ -112,30 +112,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 @@ -143,9 +143,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 @@ -155,20 +155,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 ) = @_; @@ -249,7 +249,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/ @@ -320,8 +320,8 @@ sub forward { my $c = shift; $c->dispatcher->forward( $c, @_ ) } =head2 $c->detach() -The same as C, but doesn't return to the previous action when -processing is finished. +The same as C, but doesn't return to the previous action when +processing is finished. When called with no arguments it escapes the processing chain entirely. @@ -348,23 +348,24 @@ Catalyst). $c->stash->{foo} = $bar; $c->stash( { moose => 'majestic', qux => 0 } ); $c->stash( bar => 1, gorch => 2 ); # equivalent to passing a hashref - + # stash is automatically passed to the view for use in a template $c->forward( 'MyApp::View::TT' ); =cut -sub stash { +around stash => sub { + my $orig = shift; my $c = shift; if (@_) { my $stash = @_ > 1 ? {@_} : $_[0]; croak('stash takes a hash or hashref') unless ref $stash; foreach my $key ( keys %$stash ) { - $c->{stash}->{$key} = $stash->{$key}; + $c->$orig()->{$key} = $stash->{$key}; } } - return $c->{stash}; -} + return $c->$orig(); +}; =head2 $c->error @@ -456,7 +457,7 @@ sub _comp_prefixes { return $comp; } -# Find possible names for a prefix +# Find possible names for a prefix sub _comp_names { my ( $c, @prefixes ) = @_; @@ -528,7 +529,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 @@ -542,7 +543,7 @@ sub model { @args ) if $name; if (ref $c) { - return $c->stash->{current_model_instance} + return $c->stash->{current_model_instance} if $c->stash->{current_model_instance}; return $c->model( $c->stash->{current_model} ) if $c->stash->{current_model}; @@ -573,7 +574,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 @@ -587,7 +588,7 @@ sub view { @args ) if $name; if (ref $c) { - return $c->stash->{current_view_instance} + return $c->stash->{current_view_instance} if $c->stash->{current_view_instance}; return $c->view( $c->stash->{current_view} ) if $c->stash->{current_view}; @@ -851,7 +852,7 @@ You are running an old script! EOF } - + if ( $class->debug ) { my @plugins = map { "$_ " . ( $_->VERSION || '' ) } $class->registered_plugins; @@ -960,7 +961,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 @@ -1131,7 +1132,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.

@@ -1183,8 +1184,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 ]; } @@ -1218,11 +1219,11 @@ sub execute { 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->use_stats and $stats_info; - + my $last = pop( @{ $c->stack } ); if ( my $error = $@ ) { @@ -1277,7 +1278,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, ); @@ -1292,7 +1293,7 @@ sub _stats_start_execute { } } else { - + # root-level call $c->stats->profile( begin => $action, @@ -1317,7 +1318,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; @@ -1360,12 +1361,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; @@ -1411,7 +1412,7 @@ sub finalize_headers { if ( my $location = $c->response->redirect ) { $c->log->debug(qq/Redirecting to "$location"/) if $c->debug; $c->response->header( Location => $location ); - + if ( !$c->response->body ) { # Add a default body if none is already present $c->response->body( @@ -1512,7 +1513,7 @@ sub handle_request { my $c = $class->prepare(@arguments); $c->dispatch; - $status = $c->finalize; + $status = $c->finalize; }; if ( my $error = $@ ) { @@ -1568,7 +1569,7 @@ sub prepare { $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 ); } # For on-demand data @@ -1590,7 +1591,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; @@ -1857,9 +1858,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 @@ -1867,7 +1868,7 @@ sub setup_components { 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.) @@ -1881,11 +1882,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 }; } @@ -2142,7 +2143,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); >>. @@ -2274,7 +2275,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, @@ -2288,9 +2289,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. @@ -2302,7 +2303,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; diff --git a/lib/Catalyst/AttrContainer.pm b/lib/Catalyst/AttrContainer.pm index ddfe0ab..e83706b 100644 --- a/lib/Catalyst/AttrContainer.pm +++ b/lib/Catalyst/AttrContainer.pm @@ -1,18 +1,9 @@ package Catalyst::AttrContainer; use Moose; -#use strict; -#use base qw/Class::Accessor::Fast Class::Data::Inheritable/; - use Catalyst::Exception; -use NEXT; -#dont want to ISA a C::D::I -use Class::Data::Inheritable; -{ - my $mk_classdata = Class::Data::Inheritable->can('mk_classdata'); - __PACKAGE__->meta->add_method(mk_classdata => $mk_classdata); -} +with 'Catalyst::ClassData'; __PACKAGE__->mk_classdata($_) for qw/_attr_cache _action_cache/; __PACKAGE__->_attr_cache( {} ); diff --git a/lib/Catalyst/ClassData.pm b/lib/Catalyst/ClassData.pm new file mode 100644 index 0000000..66e9b62 --- /dev/null +++ b/lib/Catalyst/ClassData.pm @@ -0,0 +1,29 @@ +package Catalyst::ClassData; + +use Moose::Role; +use Scalar::Util 'blessed'; + +sub mk_classdata { + my ($declaredclass, $attribute, $data) = @_; + confess("mk_classdata() is a class method, not an object method") + if ref $declaredclass; + + my $accessor = sub { + my $wantclass = blessed($_[0]) || $_[0]; + + return $wantclass->mk_classdata($attribute)->(@_) + if @_>1 && $wantclass ne $declaredclass; + + $data = $_[1] if @_>1; + return $data; + }; + + my $alias = "_${attribute}_accessor"; + $declaredclass->meta->add_method($alias, $accessor); + $declaredclass->meta->add_method($attribute, $accessor); + return $accessor; +} + +1; + +__END__ diff --git a/lib/Catalyst/Component.pm b/lib/Catalyst/Component.pm index 116aa9a..00ccfdd 100644 --- a/lib/Catalyst/Component.pm +++ b/lib/Catalyst/Component.pm @@ -1,11 +1,14 @@ package Catalyst::Component; -use strict; -use base qw/Class::Accessor::Fast Class::Data::Inheritable/; -use NEXT; +use Moose; +use MooseX::Adopt::Class::Accessor::Fast; use Catalyst::Utils; +with 'MooseX::Emulate::Class::Accessor::Fast'; +with 'Catalyst::ClassData'; + + =head1 NAME Catalyst::Component - Catalyst Component Base Class @@ -28,7 +31,7 @@ Catalyst::Component - Catalyst Component Base Class my ( $self, $c ) = @_; $c->response->output( $self->{foo} ); } - + 1; # Methods can be a request step @@ -41,7 +44,7 @@ Catalyst::Component - Catalyst Component Base Class =head1 DESCRIPTION -This is the universal base class for Catalyst components +This is the universal base class for Catalyst components (Model/View/Controller). It provides you with a generic new() for instantiation through Catalyst's @@ -51,38 +54,38 @@ component loader with config() support and a process() method placeholder. __PACKAGE__->mk_classdata($_) for qw/_config _plugins/; - - -sub new { +around new => sub { + my $orig = shift; my ( $self, $c ) = @_; # Temporary fix, some components does not pass context to constructor my $arguments = ( ref( $_[-1] ) eq 'HASH' ) ? $_[-1] : {}; - return $self->NEXT::new( - $self->merge_config_hashes( $self->config, $arguments ) ); -} + my $args = $self->merge_config_hashes( $self->config, $arguments ); + return $self->$orig( $args ); +}; sub COMPONENT { my ( $self, $c ) = @_; # Temporary fix, some components does not pass context to constructor my $arguments = ( ref( $_[-1] ) eq 'HASH' ) ? $_[-1] : {}; - - if ( my $new = $self->NEXT::COMPONENT( $c, $arguments ) ) { - return $new; - } - else { - if ( my $new = $self->new( $c, $arguments ) ) { - return $new; - } - else { - my $class = ref $self || $self; - my $new = $self->merge_config_hashes( - $self->config, $arguments ); - return bless $new, $class; - } - } + $self->new($c, $arguments); + +# if ( my $new = $self->NEXT::COMPONENT( $c, $arguments ) ) { +# return $new; +# } +# else { +# if ( my $new = $self->new( $c, $arguments ) ) { +# return $new; +# } +# else { +# my $class = ref $self || $self; +# my $new = $self->merge_config_hashes( +# $self->config, $arguments ); +# return bless $new, $class; +# } +# } } sub config { @@ -143,8 +146,8 @@ If this method is present (as it is on all Catalyst::Component subclasses, it is called by Catalyst during setup_components with the application class as $c and any config entry on the application for this component (for example, in the case of MyApp::Controller::Foo this would be -MyApp->config->{'Controller::Foo'}). The arguments are expected to be a -hashref and are merged with the __PACKAGE__->config hashref before calling +MyApp->config->{'Controller::Foo'}). The arguments are expected to be a +hashref and are merged with the __PACKAGE__->config hashref before calling ->new to instantiate the component. =head2 $c->config @@ -153,15 +156,15 @@ hashref and are merged with the __PACKAGE__->config hashref before calling =head2 $c->config($key, $value, ...) -Accessor for this component's config hash. Config values can be set as +Accessor for this component's config hash. Config values can be set as key value pair, or you can specify a hashref. In either case the keys -will be merged with any existing config settings. Each component in +will be merged with any existing config settings. Each component in a Catalyst application has it's own config hash. =head2 $c->process() This is the default method called on a Catalyst component in the dispatcher. -For instance, Views implement this action to render the response body +For instance, Views implement this action to render the response body when you forward to them. The default is an abstract method. =head2 $c->merge_config_hashes( $hashref, $hashref ) diff --git a/lib/Catalyst/Controller.pm b/lib/Catalyst/Controller.pm index ab77e21..f33fda5 100644 --- a/lib/Catalyst/Controller.pm +++ b/lib/Catalyst/Controller.pm @@ -1,7 +1,7 @@ package Catalyst::Controller; use strict; -use base qw/Catalyst::Component Catalyst::AttrContainer Class::Accessor::Fast/; +use base qw/Catalyst::Component Catalyst::AttrContainer/; use Catalyst::Exception; use Catalyst::Utils; @@ -17,9 +17,9 @@ Catalyst::Controller - Catalyst Controller base class package MyApp::Controller::Search use base qw/Catalyst::Controller/; - sub foo : Local { + sub foo : Local { my ($self,$c,@args) = @_; - ... + ... } # Dispatches to /search/foo =head1 DESCRIPTION @@ -181,7 +181,7 @@ sub create_action { unless ( Class::Inspector->loaded($class) ) { require Class::Inspector->filename($class); } - + return $class->new( \%args ); } @@ -310,7 +310,7 @@ controller name. For instance controller 'MyApp::Controller::Foo::Bar' will be bound to 'foo/bar'. The default Root controller is an example of setting namespace to '' (the null string). -=head2 path +=head2 path Sets 'path_prefix', as described below.