role support, in MooseX::StrictConstructor::FromRole

diff --git a/Changes b/Changes
index 985bf3e..9d34369 100644 (file)
--- a/Changes
+++ b/Changes
@@ -1,6 +1,8 @@
 {{$NEXT}}
 
-- Throw an error when used by a non-class; it won't do what users think
+- Throw an error when used by a non-class; it won't do what users think (rjbs)
+- addition of MooseX::StrictConstructor::FromRole, for people who really want
+  role support (ether)
 
 0.16     2011-04-22
 

diff --git a/lib/MooseX/StrictConstructor.pm b/lib/MooseX/StrictConstructor.pm
index 80e8453..e678bda 100644 (file)
--- a/lib/MooseX/StrictConstructor.pm
+++ b/lib/MooseX/StrictConstructor.pm
@@ -81,6 +81,12 @@ you can delete it from the hash reference of parameters.
       }
   }
 
+=head2 Usage from roles
+
+It usually doesn't make sense for a role to force its consuming class to use a
+strict constructor, so this is not normally permitted. If you desire this
+behaviour, you can use C<MooseX::StrictConstructor::FromRole> instead.
+
 =head1 BUGS
 
 Please report any bugs or feature requests to

diff --git a/lib/MooseX/StrictConstructor/FromRole.pm b/lib/MooseX/StrictConstructor/FromRole.pm
new file mode 100644 (file)
index 0000000..8c6e580
--- /dev/null
+++ b/lib/MooseX/StrictConstructor/FromRole.pm
@@ -0,0 +1,48 @@
+package MooseX::StrictConstructor::FromRole;
+
+use strict;
+use warnings;
+
+use Moose 0.94 ();
+use Moose::Exporter;
+use Moose::Util::MetaRole;
+
+{
+    my %class_meta = ( class => ['MooseX::StrictConstructor::Trait::Class'] );
+    my %role_meta;
+
+    if ( $Moose::VERSION < 1.9900 ) {
+        require MooseX::StrictConstructor::Trait::Method::Constructor;
+        $class_meta{constructor}
+            = ['MooseX::StrictConstructor::Trait::Method::Constructor'];
+    }
+    else
+    {
+        %role_meta
+            = (
+                role => ['MooseX::StrictConstructor::Trait::Role'],
+                application_to_class => ['MooseX::StrictConstructor::Trait::ApplicationToClass'],
+                application_to_role =>['MooseX::StrictConstructor::Trait::ApplicationToRole'],
+              );
+    }
+
+    Moose::Exporter->setup_import_methods(
+        class_metaroles => \%class_meta,
+        role_metaroles  => \%role_meta,
+    );
+}
+
+1;
+
+# ABSTRACT: MooseX::StrictConstructor behaviour when used from a role
+
+__END__
+
+=pod
+
+=head1 DESCRIPTION
+
+This package is equivalent to C<Moosex::StrictConstructor> except that it also
+works from roles.  This is only available in Moose 2.0 and later.
+
+=cut

diff --git a/lib/MooseX/StrictConstructor/Trait/ApplicationToClass.pm b/lib/MooseX/StrictConstructor/Trait/ApplicationToClass.pm
new file mode 100644 (file)
index 0000000..7ec0fd2
--- /dev/null
+++ b/lib/MooseX/StrictConstructor/Trait/ApplicationToClass.pm
@@ -0,0 +1,26 @@
+package MooseX::StrictConstructor::Trait::ApplicationToClass;
+use Moose::Role;
+
+around apply => sub {
+    my $orig  = shift;
+    my $self  = shift;
+    my ($role, $class) = @_;
+
+    Moose::Util::MetaRole::apply_base_class_roles(
+        for => $class,
+        roles => ['MooseX::StrictConstructor::Role::Object'],
+    );
+
+    $class = Moose::Util::MetaRole::apply_metaroles(
+        for             => $class,
+        class_metaroles => {
+            class => [ 'MooseX::StrictConstructor::Trait::Class' ],
+        }
+    );
+
+    $self->$orig( $role, $class );
+};
+
+no Moose::Role;
+
+1;

diff --git a/lib/MooseX/StrictConstructor/Trait/ApplicationToRole.pm b/lib/MooseX/StrictConstructor/Trait/ApplicationToRole.pm
new file mode 100644 (file)
index 0000000..5f8e629
--- /dev/null
+++ b/lib/MooseX/StrictConstructor/Trait/ApplicationToRole.pm
@@ -0,0 +1,26 @@
+package MooseX::StrictConstructor::Trait::ApplicationToRole;
+use Moose::Role;
+
+around apply => sub {
+    my $orig  = shift;
+    my $self  = shift;
+    my ($role1, $role2) = @_;
+
+    $role2 = Moose::Util::MetaRole::apply_metaroles(
+        for             => $role2,
+        role_metaroles => {
+            application_to_class => [
+                'MooseX::StrictConstructor::Trait::ApplicationToClass',
+            ],
+            application_to_role => [
+                'MooseX::StrictConstructor::Trait::ApplicationToRole',
+            ],
+        }
+    );
+
+    $self->$orig( $role1, $role2 );
+};
+
+no Moose::Role;
+
+1;

diff --git a/lib/MooseX/StrictConstructor/Trait/Composite.pm b/lib/MooseX/StrictConstructor/Trait/Composite.pm
new file mode 100644 (file)
index 0000000..bd8b647
--- /dev/null
+++ b/lib/MooseX/StrictConstructor/Trait/Composite.pm
@@ -0,0 +1,25 @@
+package MooseX::StrictConstructor::Trait::Composite;
+use Moose::Role;
+
+around apply_params => sub {
+    my $orig = shift;
+    my $self = shift;
+
+    $self->$orig(@_);
+
+    $self = Moose::Util::MetaRole::apply_metaroles(
+        for            => $self,
+        role_metaroles => {
+            application_to_class =>
+                ['MooseX::StrictConstructor::Trait::ApplicationToClass'],
+            application_to_role =>
+                ['MooseX::StrictConstructor::Trait::ApplicationToRole'],
+        },
+    );
+
+    return $self;
+};
+
+no Moose::Role;
+
+1;

diff --git a/lib/MooseX/StrictConstructor/Trait/Role.pm b/lib/MooseX/StrictConstructor/Trait/Role.pm
new file mode 100644 (file)
index 0000000..47cc8a6
--- /dev/null
+++ b/lib/MooseX/StrictConstructor/Trait/Role.pm
@@ -0,0 +1,9 @@
+package MooseX::StrictConstructor::Trait::Role;
+
+use Moose::Role;
+
+sub composition_class_roles { 'MooseX::StrictConstructor::Trait::Composite' }
+
+no Moose::Role;
+
+1;

diff --git a/t/role.t b/t/role.t
new file mode 100644 (file)
index 0000000..4d62bae
--- /dev/null
+++ b/t/role.t
@@ -0,0 +1,37 @@
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Fatal;
+use Test::Moose qw( with_immutable );
+
+{
+    package Role;
+
+    use Moose::Role;
+    use MooseX::StrictConstructor::FromRole;
+
+    has 'size' => ( is => 'rw' );
+}
+
+{
+    package Standard;
+
+    use Moose;
+    with 'Role';
+
+    has 'thing' => ( is => 'rw' );
+}
+
+my @classes = qw( Standard );
+with_immutable {
+
+    like(
+        exception { Standard->new( thing => 1, bad => 99 ) },
+        qr/unknown attribute.+: bad/,
+        'strict constructor applied from role blows up on unknown params'
+    );
+}
+@classes;
+
+done_testing();