fixed bugs in type constraints and cored some extensibility features
John Napiorkowski [Tue, 14 Apr 2015 18:51:09 +0000 (13:51 -0500)]
Changes
lib/Catalyst.pm
lib/Catalyst/Action.pm
lib/Catalyst/ActionChain.pm
lib/Catalyst/Delta.pod
lib/Catalyst/Upgrading.pod
lib/Catalyst/Utils.pm
t/Test/Apple.pm [new file with mode: 0644]
t/class_traits.t [new file with mode: 0644]
t/configured_comps.t [new file with mode: 0644]
t/inject_component_util.t [new file with mode: 0644]

diff --git a/Changes b/Changes
index 416e2b7..a93c67b 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,6 +1,6 @@
 # This file documents the revision history for Perl extension Catalyst.
 
-5.90089_002 - 2015-04-03
+5.90089_002 - 2015-04-15
   - Changed the way we check for presence of Type::Tiny in a test case to be
     more explicit in the version requirement.  Hopefully a fix for reported
     test fail.
   - Additional changes to type constraint detection to between determine when a
     type constraint for reference types have a measured number of arguments or
     not.  clarify restriction on reference type constraints.
+  - Several bugs with type constraints and uri_for squashed.  More test cases
+    around all the argument type constraints to tighten scope of action.
+  - NEW FEATURE: New method in Catalyst::Utils 'inject_component', which is a core
+    version of the previously external addon 'CatalystX::InjectComponent'.  You should
+    start to convert your existing code which uses the stand alone version, since
+    going forward only the core version will be supported.
+  - NEW FEATURE: Concepts from 'CatalystX::RoleApplicator' have been moved to core
+    so we now have the follow application attributes 'request_class_traits',
+    'response_class_traits' and 'stats_class_traits' which allow you to compose
+    traits for these core Catalyst classes without needing to create subclasses. So
+    in general any request or response trait on CPAN that used 'CatalystX::RoleApplicator'
+    should now just work with this core feature.
+  - Only create a stats object if you are using stats.  This is a minor performance
+    optimization, but there's a small chance it is a breaking change, so please
+    report any stats related issues.
 
 5.90089_001 - 2015-03-26
   - New development branch synched with 5.90085.
-  - New Feature: Type Constraints on Args/CaptureArgs.  Allows you to declare
+  - NEW FEATURE: Type Constraints on Args/CaptureArgs.  Allows you to declare
     a Moose, MooseX::Types or Type::Tiny named constraint on your Arg or 
     CaptureArg.
   - When using $c->uri_for (or the derived $c->uri_for_action) and the target
index 8e487f5..27b421e 100644 (file)
@@ -63,7 +63,9 @@ has request => (
     is => 'rw',
     default => sub {
         my $self = shift;
-        $self->request_class->new($self->_build_request_constructor_args);
+        my $class = ref $self;
+        my $composed_request_class = $class->composed_request_class;
+        return $composed_request_class->new( $self->_build_request_constructor_args);
     },
     lazy => 1,
 );
@@ -77,11 +79,19 @@ sub _build_request_constructor_args {
     \%p;
 }
 
+sub composed_request_class {
+  my $class = shift;
+  return $class->_composed_request_class ||
+    $class->_composed_request_class(Moose::Util::with_traits($class->request_class, @{$class->request_class_traits||[]}));
+}
+
 has response => (
     is => 'rw',
     default => sub {
         my $self = shift;
-        $self->response_class->new($self->_build_response_constructor_args);
+        my $class = ref $self;
+        my $composed_response_class = $class->composed_response_class;
+        return $composed_response_class->new( $self->_build_response_constructor_args);
     },
     lazy => 1,
 );
@@ -92,6 +102,12 @@ sub _build_response_constructor_args {
     };
 }
 
+sub composed_response_class {
+  my $class = shift;
+  return $class->_composed_response_class ||
+    $class->_composed_response_class(Moose::Util::with_traits($class->response_class, @{$class->response_class_traits||[]}));
+}
+
 has namespace => (is => 'rw');
 
 sub depth { scalar @{ shift->stack || [] }; }
@@ -120,12 +136,21 @@ __PACKAGE__->mk_classdata($_)
   for qw/components arguments dispatcher engine log dispatcher_class
   engine_loader context_class request_class response_class stats_class
   setup_finished _psgi_app loading_psgi_file run_options _psgi_middleware
-  _data_handlers _encoding _encode_check finalized_default_middleware/;
+  _data_handlers _encoding _encode_check finalized_default_middleware
+  request_class_traits response_class_traits stats_class_traits
+  _composed_request_class _composed_response_class _composed_stats_class/;
 
 __PACKAGE__->dispatcher_class('Catalyst::Dispatcher');
 __PACKAGE__->request_class('Catalyst::Request');
 __PACKAGE__->response_class('Catalyst::Response');
 __PACKAGE__->stats_class('Catalyst::Stats');
+
+sub composed_stats_class {
+  my $class = shift;
+  return $class->_composed_stats_class ||
+    $class->_composed_stats_class(Moose::Util::with_traits($class->stats_class, @{$class->stats_class_traits||[]}));
+}
+
 __PACKAGE__->_encode_check(Encode::FB_CROAK | Encode::LEAVE_SRC);
 
 # Remember to update this in Catalyst::Runtime as well!
@@ -1487,8 +1512,8 @@ sub uri_for {
         }
 
         if($num_captures) {
-          unless($expanded_action->match_captures($c, $captures)) {
-            carp "captures [@{$captures}] do not match the type constraints in actionchain ending with '$action'";
+          unless($expanded_action->match_captures_constraints($c, $captures)) {
+            carp "captures [@{$captures}] do not match the type constraints in actionchain ending with '$expanded_action'";
             return;
           }
         }
@@ -2269,8 +2294,10 @@ sub prepare {
 
     $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->use_stats) {
+      $c->stats($class->composed_stats_class->new)->enable;
+    }
+
     if ( $c->debug || $c->config->{enable_catalyst_header} ) {
         $c->res->headers->header( 'X-Catalyst' => $Catalyst::VERSION );
     }
@@ -2676,10 +2703,26 @@ sub prepare_write { my $c = shift; $c->engine->prepare_write( $c, @_ ) }
 
 Returns or sets the request class. Defaults to L<Catalyst::Request>.
 
+=head2 $app->request_class_traits
+
+An arrayref of L<Moose::Role>s which are applied to the request class.  
+
+=head2 $app->composed_request_class
+
+This is the request class which has been composed with any request_class_traits.
+
 =head2 $c->response_class
 
 Returns or sets the response class. Defaults to L<Catalyst::Response>.
 
+=head2 $app->response_class_traits
+
+An arrayref of L<Moose::Role>s which are applied to the response class.
+
+=head2 $app->composed_response_class
+
+This is the request class which has been composed with any response_class_traits.
+
 =head2 $c->read( [$maxlength] )
 
 Reads a chunk of data from the request body. This method is designed to
@@ -2797,6 +2840,15 @@ sub setup_components {
             $class->components->{ $component } = $class->setup_component($component);
         }
     }
+
+    # Inject a component or wrap a stand alone class in an adaptor
+    #my @configured_comps = grep { not($class->component($_)||'') }
+    # grep { /^(Model)::|(View)::|(Controller::)/ }
+    #   keys %{$class->config ||+{}};
+
+    #foreach my $configured_comp(@configured_comps) {
+      #warn $configured_comp;
+      #}
 }
 
 =head2 $c->locate_components( $setup_component_config )
@@ -3683,6 +3735,14 @@ by itself.
 
 Returns or sets the stats (timing statistics) class. L<Catalyst::Stats|Catalyst::Stats> is used by default.
 
+=head2 $app->stats_class_traits
+
+A arrayref of L<Moose::Role>s that are applied to the stats_class before creating it.
+
+=head2 $app->composed_stats_class
+
+this is the stats_class composed with any 'stats_class_traits'.
+
 =head2 $c->use_stats
 
 Returns 1 when L<< stats collection|/"-Stats" >> is enabled.
index 0a38d75..32d9b99 100644 (file)
@@ -371,28 +371,37 @@ sub match_captures {
   my @captures = @{$captures||[]};
 
   return 1 unless scalar(@captures); # If none, just say its ok
+  return $self->has_captures_constraints ?
+    $self->match_captures_constraints($c, $captures) : 1;
 
-  if($self->has_captures_constraints) {
-    if(
-      $self->captures_constraints_count == 1 &&
-      (
-        $self->captures_constraints->[0]->is_a_type_of('Ref') ||
-        $self->captures_constraints->[0]->is_a_type_of('ClassName')
-      )
-    ) {
-      return $self->captures_constraints->[0]->check($captures);
-    } else {
-      for my $i(0..$#captures) {
-        $self->captures_constraints->[$i]->check($captures[$i]) || return 0;
-      }
-      return 1;
-      }
+  return 1;
+}
+
+sub match_captures_constraints {
+  my ($self, $c, $captures) = @_;
+  my @captures = @{$captures||[]};
+
+  # Match is positive if you don't have any.
+  return 1 unless $self->has_captures_constraints;
+
+  if(
+    $self->captures_constraints_count == 1 &&
+    (
+      $self->captures_constraints->[0]->is_a_type_of('Ref') ||
+      $self->captures_constraints->[0]->is_a_type_of('ClassName')
+    )
+  ) {
+    return $self->captures_constraints->[0]->check($captures);
   } else {
+    for my $i(0..$#captures) {
+      $self->captures_constraints->[$i]->check($captures[$i]) || return 0;
+    }
     return 1;
-  }
-  return 1;
+    }
+
 }
 
+
 sub compare {
     my ($a1, $a2) = @_;
     return $a1->normalized_arg_number <=> $a2->normalized_arg_number;
@@ -456,6 +465,11 @@ of the captures for this action.
 Returning true from this method causes the chain match to continue, returning
 makes the chain not match (and alternate, less preferred chains will be attempted).
 
+=head2 match_captures_constraints ($c, \@captures);
+
+Does the \@captures given match any constraints (if any constraints exist).  Returns
+true if you ask but there are no constraints.
+
 =head2 match_args($c, $args)
 
 Does the Args match or not?
index 873e3a8..4f72839 100644 (file)
@@ -71,6 +71,17 @@ sub match_captures {
   }
   return 1;
 }
+sub match_captures_constraints {
+  my ($self, $c, $captures) = @_;
+  my @captures = @{$captures||[]};
+
+  foreach my $link(@{$self->chain}) {
+    my @local_captures = splice @captures,0,$link->number_of_captures;
+    next unless $link->has_captures_constraints;
+    return unless $link->match_captures_constraints($c, \@local_captures);
+  }
+  return 1;
+}
 
 # the scheme defined at the end of the chain is the one we use
 # but warn if too many.
index bbc1a36..e965025 100755 (executable)
@@ -24,6 +24,11 @@ your arguments to $c->uri_for(...) must match those constraints.
 
 See L<Catalyst::RouteMatching> for more.
 
+=head2 Move CatalystX::InjectComponent into core
+
+L<Catalyst::Utils> has a new method 'inject_component' which works the same as the method of
+the same name in L<CatalystX::InjectComponent>.
+
 =head2 VERSION 5.90080+
 
 The biggest change in this release is that UTF8 encoding is now enabled by
index e210bbb..5a5a857 100644 (file)
@@ -2,6 +2,25 @@
 
 Catalyst::Upgrading - Instructions for upgrading to the latest Catalyst
 
+=head1 Upgrading to Catalyst 5.90090
+
+L<Catalyst::Utils> has a new method 'inject_component' which works the same as the method of
+the same name in L<CatalystX::InjectComponent>.  You should start converting any
+use of the non core method in your code as future changes to Catalyst will be
+sychronized to the core method first.  We reserve the right to cease support
+of the non core version should we reach a point in time where it cannot be
+properly supported as an external module.  Luckily this should be a trivial
+search and replace.  Change all occurances of:
+
+    CatalystX::InjectComponent->inject(...)
+
+Into
+
+    Catalyst::Utils::inject_component(...)
+
+and we expect everything to work the same (we'd consider it not working the same
+to be a bug, and please report it.)
+
 =head1 Upgrading to Catalyst 5.90085
 
 In this version of Catalyst we made a small change to Chained Dispatching so
index 1bccecb..babcfa3 100644 (file)
@@ -11,6 +11,7 @@ use Class::Load 'is_class_loaded';
 use String::RewritePrefix;
 use Class::Load ();
 use namespace::clean;
+use Devel::InnerPackage;
 
 =head1 NAME
 
@@ -502,7 +503,78 @@ sub apply_registered_middleware {
     return $new_psgi;
 }
 
+=head2 inject_component
 
+Used to add components at runtime:
+
+    into        The Catalyst package to inject into (e.g. My::App)
+    component   The component package to inject
+    as          An optional moniker to use as the package name for the derived component
+
+For example:
+
+    Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple )
+
+        The above will create 'My::App::Controller::Other::App::Controller::Apple'
+
+    Catalyst::Utils::inject_component( into => My::App, component => Other::App::Controller::Apple, as => Apple )
+
+        The above will create 'My::App::Controller::Apple'
+
+    Catalyst::Utils::inject_component( into => $myapp, component => 'MyRootV', as => 'Controller::Root' );
+
+Will inject Controller, Model, and View components into your Catalyst application
+at setup (run)time. It does this by creating a new package on-the-fly, having that
+package extend the given component, and then having Catalyst setup the new component
+(via $app->setup_component).
+
+B<NOTE:> This is basically a core version of L<CatalystX::InjectComponent>.  If you were using that
+you can now use this safely instead.  Going forward changes required to make this work will be
+synchronized with the core method.
+
+=cut
+
+sub inject_component {
+    my %given = @_;
+    my ($into, $component, $as) = @given{qw/into component as/};
+
+    croak "No Catalyst (package) given" unless $into;
+    croak "No component (package) given" unless $component;
+
+    Class::Load::load_class($component);
+
+    $as ||= $component;
+    unless ( $as =~ m/^(?:Controller|Model|View)::/ || $given{skip_mvc_renaming} ) {
+        my $category;
+        for (qw/ Controller Model View /) {
+            if ( $component->isa( "Catalyst::$_" ) ) {
+                $category = $_;
+                last;
+            }
+        }
+        croak "Don't know what kind of component \"$component\" is" unless $category;
+        $as = "${category}::$as";
+    }
+    my $component_package = join '::', $into, $as;
+
+    unless ( Class::Load::is_class_loaded $component_package ) {
+        eval "package $component_package; use base qw/$component/; 1;" or
+            croak "Unable to build component package for \"$component_package\": $@";
+        (my $file = "$component_package.pm") =~ s{::}{/}g;
+        $INC{$file} ||= 1;    
+    }
+
+    my $_setup_component = sub {
+      my $into = shift;
+      my $component_package = shift;
+      $into->components->{$component_package} = $into->setup_component( $component_package );
+    };
+
+    $_setup_component->( $into, $component_package );
+    for my $inner_component_package ( Devel::InnerPackage::list_packages( $component_package ) ) {
+        $_setup_component->( $into, $inner_component_package );
+    }
+}
 
 =head1 PSGI Helpers
 
diff --git a/t/Test/Apple.pm b/t/Test/Apple.pm
new file mode 100644 (file)
index 0000000..c6f354e
--- /dev/null
@@ -0,0 +1,14 @@
+package t::Test::Apple;
+
+use strict;
+use warnings;
+
+use parent qw/Catalyst::Controller/;
+
+sub default :Path {
+}
+
+sub apple :Local {
+}
+
+1;
diff --git a/t/class_traits.t b/t/class_traits.t
new file mode 100644 (file)
index 0000000..f796323
--- /dev/null
@@ -0,0 +1,44 @@
+use strict;
+use warnings;
+use Test::More;
+use Class::MOP;
+
+BEGIN {
+  package TestRole;
+  use Moose::Role;
+
+  sub a { 'a' }
+  sub b { 'b' }
+}
+{
+  package TestApp;
+  use Catalyst;
+
+  __PACKAGE__->request_class_traits([qw/TestRole/]);
+  __PACKAGE__->response_class_traits([qw/TestRole/]);
+  __PACKAGE__->stats_class_traits([qw/TestRole/]);
+
+  __PACKAGE__->setup;
+}
+foreach my $class_prefix (qw/request response stats/) {
+  my $method = 'composed_' .$class_prefix. '_class';
+  ok(
+    Class::MOP::class_of(TestApp->$method)->does_role('TestRole'),
+    "$method does TestRole",
+  );
+}
+
+use Catalyst::Test 'TestApp';
+
+my ($res, $c) = ctx_request '/';
+
+is $c->req->a, 'a';
+is $c->req->b, 'b';
+is $c->res->a, 'a';
+is $c->res->b, 'b';
+
+done_testing;
diff --git a/t/configured_comps.t b/t/configured_comps.t
new file mode 100644 (file)
index 0000000..84a5a8e
--- /dev/null
@@ -0,0 +1,76 @@
+use warnings;
+use strict;
+use HTTP::Request::Common;
+use Test::More;
+
+{
+  package Local::Controller::Errors;
+
+  use Moose;
+  use MooseX::MethodAttributes;
+
+  extends 'Catalyst::Controller';
+
+  has ['a', 'b'] => (is=>'ro', required=>1);
+
+  sub not_found :Local { pop->res->from_psgi_response(404, [], ['Not Found']) }
+
+  package MyApp::Model::User;
+  $INC{'MyApp/Model/User.pm'} = __FILE__;
+
+  use base 'Catalyst::Model';
+
+  our %users = (
+    1 => { name => 'john', age => 46 },
+    2 => { name => 'mary', age => 36 },
+    3 => { name => 'ian', age => 25 },
+    4 => { name => 'visha', age => 18 },
+  );
+
+  sub find {
+    my ($self, $id) = @_;
+    my $user = $users{$id} || return;
+    return bless $user, "MyApp::Model::User::user";
+  }
+
+  package MyApp::Controller::Root;
+  $INC{'MyApp/Controller/Root.pm'} = __FILE__;
+
+  use Moose;
+  use MooseX::MethodAttributes;
+
+  extends 'Catalyst::Controller';
+
+  sub user :Local Args(1) {
+    my ($self, $c, $int) = @_;
+    my $user = $c->model("User")->find($int);
+    $c->res->body("name: $user->{name}, age: $user->{age}");
+  }
+
+  sub default :Default {
+    my ($self, $c, $int) = @_;
+    $c->res->body('default');
+  }
+
+  MyApp::Controller::Root->config(namespace=>'');
+
+  package MyApp;
+  use Catalyst;
+
+  MyApp->config({
+    'Controller::Err' => {
+      component => 'Local::Controller::Errors'
+    }
+  });
+
+  MyApp->setup;
+}
+
+use Catalyst::Test 'MyApp';
+
+{
+  my $res = request '/user/1';
+  is $res->content, 'name: john, age: 46';
+}
+
+done_testing;
diff --git a/t/inject_component_util.t b/t/inject_component_util.t
new file mode 100644 (file)
index 0000000..c757d9c
--- /dev/null
@@ -0,0 +1,41 @@
+use strict;
+use warnings; 
+use Test::More;
+use Catalyst::Utils;
+BEGIN {
+package Model::Banana;
+use base qw/Catalyst::Model/;
+package TestCatalyst; $INC{'TestCatalyst.pm'} = 1;
+use Catalyst::Runtime '5.70';
+use Moose;
+BEGIN { extends qw/Catalyst/ }
+use Catalyst;
+after 'setup_components' => sub {
+    my $self = shift;
+    Catalyst::Utils::inject_component( into => __PACKAGE__, component => 'Model::Banana' );
+    Catalyst::Utils::inject_component( into => __PACKAGE__, component => 't::Test::Apple' );
+    Catalyst::Utils::inject_component( into => __PACKAGE__, component => 'Model::Banana', as => 'Cherry' );
+    Catalyst::Utils::inject_component( into => __PACKAGE__, component => 't::Test::Apple', as => 'Apple' );
+};
+TestCatalyst->config( 'home' => '.' );
+TestCatalyst->setup;
+}
+package main;
+use Catalyst::Test qw/TestCatalyst/;
+ok( TestCatalyst->controller( $_ ) ) for qw/ Apple t::Test::Apple /;
+ok( TestCatalyst->model( $_ ) ) for qw/ Banana Cherry /;
+
+done_testing;