Use Moose's meta traits more effectively so that single args may be d…

…eclared in roles.

Changes

@@ -1,6 +1,8 @@
 Revision history for Perl extension MooseX::SingleArg.
 
 {{$NEXT}}
+ - Use Moose's meta traits more effectively so that single args may be
+   declared in roles.
 
 0.03      2012-03-20
  - Comment on MooseX::OneArgNew.

README.pod

@@ -18,10 +18,9 @@ MooseX::SingleArg - No-fuss instantiation of Moose objects using a single argume
 
 =head1 DESCRIPTION
 
-This module provides a role and declarative sugar for allowing Moose instances
-to be constructed with a single argument.  Your class must use this module and
-then use the single_arg method to declare which of the class's attributes will
-be assigned the single argument value.
+This module allows Moose instances to be constructed with a single argument.
+Your class or role must use this module and then use the single_arg method to
+declare which attribute will be assigned the single argument value.
 
 If the class is constructed using the typical argument list name/value pairs,
 or with a hashref, then things work as is usual.  But, if the arguments are a

lib/MooseX/SingleArg.pm

@@ -22,10 +22,9 @@ MooseX::SingleArg - No-fuss instantiation of Moose objects using a single argume
 
 =head1 DESCRIPTION
 
-This module provides a role and declarative sugar for allowing Moose instances
-to be constructed with a single argument.  Your class must use this module and
-then use the single_arg method to declare which of the class's attributes will
-be assigned the single argument value.
+This module allows Moose instances to be constructed with a single argument.
+Your class or role must use this module and then use the single_arg method to
+declare which attribute will be assigned the single argument value.
 
 If the class is constructed using the typical argument list name/value pairs,
 or with a hashref, then things work as is usual.  But, if the arguments are a
@@ -68,78 +67,35 @@ argument when force is on.
 use Carp qw( croak );
 
 Moose::Exporter->setup_import_methods(
-    with_meta => [ 'single_arg' ],
+    with_meta => ['single_arg'],
+    class_metaroles => {
+        class => ['MooseX::SingleArg::Meta::Class'],
+    },
+    role_metaroles => {
+        role                 => ['MooseX::SingleArg::Meta::Role'],
+        application_to_class => ['MooseX::SingleArg::Meta::ToClass'],
+        application_to_role  => ['MooseX::SingleArg::Meta::ToRole'],
+    },
+    base_class_roles => ['MooseX::SingleArg::Meta::Object'],
 );
 
 sub single_arg {
-    my ($meta, $arg, %params) = @_;
+    my ($meta, $name, %args) = @_;
 
     my $class = $meta->name();
-    croak "A single arg has already been declared for $class" if $class->_has_single_arg();
+    croak "A single arg has already been declared for $class" if $meta->has_single_arg();
 
-    $class->_single_arg( $arg );
+    $meta->single_arg( $name );
 
-    foreach my $param (keys %params) {
-        my $method = '_' . $param . '_single_arg';
-        croak("Unknown single_arg parameter $param") if !$class->can($method);
-        $class->$method( $params{$param} );
+    foreach my $arg (keys %args) {
+        my $method = $arg . '_single_arg';
+        croak("Unknown single_arg argument $arg") if !$meta->can($method);
+        $meta->$method( $args{$arg} );
     }
 
     return;
 }
 
-sub init_meta {
-    shift;
-    my %args = @_;
-
-    Moose->init_meta( %args );
-
-    my $class = $args{for_class};
-
-    Moose::Util::MetaRole::apply_base_class_roles(
-        for_class => $class,
-        roles => [ 'MooseX::SingleArg::Role' ],
-    );
-
-    return $class->meta();
-}
-
-{
-    package MooseX::SingleArg::Role;
-    use Moose::Role;
-
-    use Carp qw( croak );
-    use MooseX::ClassAttribute;
-
-    class_has _single_arg => (
-        is        => 'rw',
-        isa       => 'Str',
-        predicate => '_has_single_arg',
-    );
-
-    class_has _force_single_arg => (
-        is        => 'rw',
-        isa       => 'Bool',
-    );
-
-    around BUILDARGS => sub{
-        my $orig = shift;
-        my $class = shift;
-
-        my $single_arg = $class->_single_arg();
-        croak("single_arg() has not been called for $class") if !$single_arg;
-
-        my $force = $class->_force_single_arg();
-        croak("$class accepts only one argument for $single_arg") if $force and @_>1;
-
-        if (@_==1 and ($force or ref($_[0]) ne 'HASH')) {
-            return $class->$orig( $single_arg => $_[0] );
-        }
-
-        return $class->$orig( @_ );
-    };
-}
-
 1;
 __END__
 

lib/MooseX/SingleArg/Meta/Class.pm

@@ -0,0 +1,17 @@
+package # Hide from the indexer for now until docs are added later.
+    MooseX::SingleArg::Meta::Class;
+use Moose::Role;
+
+has single_arg => (
+    is        => 'rw',
+    isa       => 'Str',
+    predicate => 'has_single_arg',
+);
+
+has force_single_arg => (
+    is      => 'rw',
+    isa     => 'Bool',
+    default => 0,
+);
+
+1;

lib/MooseX/SingleArg/Meta/Object.pm

@@ -0,0 +1,24 @@
+package # Hide from the indexer for now until docs are added later.
+    MooseX::SingleArg::Meta::Object;
+use Moose::Role;
+
+use Carp qw( croak );
+
+around BUILDARGS => sub{
+    my $orig  = shift;
+    my $class = shift;
+
+    my $meta = $class->meta();
+    croak("single_arg() has not been called for $class") if !$meta->has_single_arg();
+
+    my $force = $meta->force_single_arg();
+    croak("$class accepts only one argument") if $force and @_>1;
+
+    if (@_==1 and ($force or ref($_[0]) ne 'HASH')) {
+        return $class->$orig( $meta->single_arg() => $_[0] );
+    }
+
+    return $class->$orig( @_ );
+};
+
+1;

lib/MooseX/SingleArg/Meta/Role.pm

@@ -0,0 +1,17 @@
+package # Hide from the indexer for now until docs are added later.
+    MooseX::SingleArg::Meta::Role;
+use Moose::Role;
+
+has single_arg => (
+    is        => 'rw',
+    isa       => 'Str',
+    predicate => 'has_single_arg',
+);
+
+has force_single_arg => (
+    is      => 'rw',
+    isa     => 'Bool',
+    default => 0,
+);
+
+1;

lib/MooseX/SingleArg/Meta/ToClass.pm

@@ -0,0 +1,29 @@
+package # Hide from the indexer for now until docs are added later.
+    MooseX::SingleArg::Meta::ToClass;
+use Moose::Role;
+
+around apply => sub {
+    my $orig      = shift;
+    my $self      = shift;
+    my $from_role = shift;
+    my $to_class  = shift;
+
+    $to_class = Moose::Util::MetaRole::apply_metaroles(
+        for             => $to_class,
+        class_metaroles => {
+            class => ['MooseX::SingleArg::Meta::Class'],
+        },
+    );
+
+    Moose::Util::MetaRole::apply_base_class_roles(
+        for   => $to_class,
+        roles => ['MooseX::SingleArg::Meta::Object'],
+    );
+
+    $to_class->single_arg( $from_role->single_arg() ) if $from_role->has_single_arg();
+    $to_class->force_single_arg( $from_role->force_single_arg() );
+
+    return $self->$orig( $from_role, $to_class );
+};
+
+1;

lib/MooseX/SingleArg/Meta/ToRole.pm

@@ -0,0 +1,26 @@
+package # Hide from the indexer for now until docs are added later.
+    MooseX::SingleArg::Meta::ToRole;
+use Moose::Role;
+
+around apply => sub{
+    my $orig      = shift;
+    my $self      = shift;
+    my $from_role = shift;
+    my $to_role   = shift;
+
+    $to_role = Moose::Util::MetaRole::apply_metaroles(
+        for            => $to_role,
+        role_metaroles => {
+            role                 => ['MooseX::SingleArg::Meta::Role'],
+            application_to_class => ['MooseX::SingleArg::Meta::ToClass'],
+            application_to_role  => ['MooseX::SingleArg::Meta::ToRole'],
+        },
+    );
+
+    $to_role->single_arg( $from_role->single_arg() ) if $from_role->has_single_arg();
+    $to_role->force_single_arg( $from_role->force_single_arg() );
+
+    return $self->$orig( $from_role, $to_role );
+};
+
+1;

t/basic.t

@@ -55,6 +55,28 @@ require_ok('MooseX::SingleArg');
     is( $obj->arg2(), 789, '( 789 ) sets arg2 to 789' );
 }
 
+{
+    package MyRole;
+    use Moose::Role;
+    use MooseX::SingleArg;
+    single_arg 'blah';
+    has blah => (
+        is => 'ro',
+        isa => 'Str',
+    );
+}
+
+{
+    package MyClass2;
+    use Moose;
+    with 'MyRole';
+}
+
+{
+    my $obj = MyClass2->new( 55 );
+    is( $obj->blah(), 55, 'works with roles too' );
+}
+
 like(
     exception {
         package Broken;