From: Alex J. G. Burzyński <ajgb@cpan.org>
Date: Fri, 29 Jul 2011 10:29:42 +0000 (+0100)
Subject: added BUILDARGS support
X-Git-Tag: v0.009011~18
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=a17be455d30de29a1979c1bececb5419ca3a672a;hp=1eba910c9cdaf6560b50f9ac5d6033bde4e84c94;p=gitmo%2FRole-Tiny.git

added BUILDARGS support
---

diff --git a/Changes b/Changes
index 75994d9..61c642e 100644
--- a/Changes
+++ b/Changes
@@ -1,3 +1,5 @@
+  - add support for BUILDARGS
+
 0.009010 - 2011-07-20
   - missing new files for Role::Tiny::With
 
diff --git a/lib/Method/Generate/Constructor.pm b/lib/Method/Generate/Constructor.pm
index 1d7e740..23d9c03 100644
--- a/lib/Method/Generate/Constructor.pm
+++ b/lib/Method/Generate/Constructor.pm
@@ -81,7 +81,7 @@ sub _cap_call {
 
 sub _generate_args {
   my ($self) = @_;
-  q{    my $args = ref($_[0]) eq 'HASH' ? $_[0] : { @_ };}."\n";
+  q{    my $args = $class->BUILDARGS(@_);}."\n";
 }
 
 sub _assign_new {
diff --git a/lib/Moo.pm b/lib/Moo.pm
index 8bfe1ce..16b7db4 100644
--- a/lib/Moo.pm
+++ b/lib/Moo.pm
@@ -97,6 +97,9 @@ sub _constructor_maker_for {
 }
 
 1;
+=pod
+
+=encoding utf-8
 
 =head1 NAME
 
@@ -188,7 +191,25 @@ or
 
 =head2 BUILDARGS
 
-This feature from Moose is not yet supported.
+ around BUILDARGS => sub {
+   my $orig = shift;
+   my ( $class, @args ) = @_;
+
+   unshift @args, "attr1" if @args % 2 == 1;
+
+   return $class->$orig(@args);
+ };
+
+ Foo::Bar->new( 3 );
+
+The default implementation of this method accepts a hash or hash reference of
+named parameters. If it receives a single argument that isn't a hash reference
+it throws an error.
+
+You can override this method in your class to handle other types of options
+passed to the constructor.
+
+This method should always return a hash reference of named options.
 
 =head2 BUILDALL
 
@@ -424,6 +445,8 @@ ribasushi - Peter Rabbitson (cpan:RIBASUSHI) <ribasushi@cpan.org>
 
 chip - Chip Salzenberg (cpan:CHIPS) <chip@pobox.com>
 
+ajgb - Alex J. G. Burzyński (cpan:AJGB) <ajgb@cpan.org>
+
 =head1 COPYRIGHT
 
 Copyright (c) 2010-2011 the Moo L</AUTHOR> and L</CONTRIBUTORS>
diff --git a/lib/Moo/Object.pm b/lib/Moo/Object.pm
index f62bc35..70daca4 100644
--- a/lib/Moo/Object.pm
+++ b/lib/Moo/Object.pm
@@ -18,6 +18,25 @@ sub new {
       };
 }
 
+sub BUILDARGS {
+    my $class = shift;
+    if ( scalar @_ == 1 ) {
+        unless ( defined $_[0] && ref $_[0] eq 'HASH' ) {
+            die "Single parameters to new() must be a HASH ref"
+                ." data => ". $_[0];
+        }
+        return { %{ $_[0] } };
+    }
+    elsif ( @_ % 2 ) {
+        warn "The new() method for $class expects a hash reference or a key/value list."
+                . " You passed an odd number of arguments";
+        return { @_, undef };
+    }
+    else {
+        return {@_};
+    }
+}
+
 sub BUILDALL {
   my $self = shift;
   $self->${\(($BUILD_MAKER ||= do {
diff --git a/t/buildargs.t b/t/buildargs.t
new file mode 100644
index 0000000..1a541bd
--- /dev/null
+++ b/t/buildargs.t
@@ -0,0 +1,94 @@
+use strictures 1;
+use Test::More;
+
+{
+    package Qux;
+    use Moo;
+
+    has bar => ( is => "rw" );
+    has baz => ( is => "rw" );
+
+    package Quux;
+    use Moo;
+
+    extends qw(Qux);
+}
+{
+    package Foo;
+    use Moo;
+
+    has bar => ( is => "rw" );
+    has baz => ( is => "rw" );
+
+    sub BUILDARGS {
+        my ( $class, @args ) = @_;
+        unshift @args, "bar" if @args % 2 == 1;
+        return $class->SUPER::BUILDARGS(@args);
+    }
+
+    package Bar;
+    use Moo;
+
+    extends qw(Foo);
+}
+
+{
+    package Baz;
+    use Moo;
+
+    has bar => ( is => "rw" );
+    has baz => ( is => "rw" );
+
+    around BUILDARGS => sub {
+        my $orig = shift;
+        my ( $class, @args ) = @_;
+
+        unshift @args, "bar" if @args % 2 == 1;
+
+        return $class->$orig(@args);
+    };
+
+    package Biff;
+    use Moo;
+
+    extends qw(Baz);
+}
+
+foreach my $class (qw(Foo Bar Baz Biff)) {
+    is( $class->new->bar, undef, "no args" );
+    is( $class->new( bar => 42 )->bar, 42, "normal args" );
+    is( $class->new( 37 )->bar, 37, "single arg" );
+    {
+        my $o = $class->new(bar => 42, baz => 47);
+        is($o->bar, 42, '... got the right bar');
+        is($o->baz, 47, '... got the right baz');
+    }
+    {
+        my $o = $class->new(42, baz => 47);
+        is($o->bar, 42, '... got the right bar');
+        is($o->baz, 47, '... got the right baz');
+    }
+}
+
+foreach my $class (qw(Qux Quux)) {
+    my $o = $class->new(bar => 42, baz => 47);
+    is($o->bar, 42, '... got the right bar');
+    is($o->baz, 47, '... got the right baz');
+
+    eval {
+        $class->new( 37 );
+    };
+    like( $@, qr/Single parameters to new\(\) must be a HASH ref/,
+        "new() requires a list or a HASH ref"
+    );
+
+    eval {
+        $class->new( [ 37 ] );
+    };
+    like( $@, qr/Single parameters to new\(\) must be a HASH ref/,
+        "new() requires a list or a HASH ref"
+    );
+}
+
+done_testing;
+