From: Tomas Doran <bobtfish@bobtfish.net>
Date: Tue, 29 Jul 2008 09:03:51 +0000 (+0000)
Subject: Avoid bug with immutable / around new in Moose by using BUILD method instead. Test... 
X-Git-Tag: 0.00400~3
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=144866f7751f8516d55c33c6de407b9086d8c3df;p=gitmo%2FMooseX-Emulate-Class-Accessor-Fast.git

Avoid bug with immutable / around new in Moose by using BUILD method instead. Test constructing objects in various ways / in various lineages to demonstrate the issue.
---

diff --git a/Changes b/Changes
index 090ebc6..8cdcbed 100644
--- a/Changes
+++ b/Changes
@@ -1,6 +1,9 @@
+0.00300    Jul XX, 2008
+           - Replace around 'new' with a BUILD method. Faster and avoids Moose
+             bug with around/immutable and sub-classes.
 0.00200    Mar 28, 2008
            - Extend BUILDALL to store constructor keys in the obj. hashref
            - Minor fix to make sure Adopt doesn't trip PAUSE perms
            - Bye bye auto_install.
 0.00100    Mar 15, 2008
-           - Initial Release!
\ No newline at end of file
+           - Initial Release!
diff --git a/lib/MooseX/Emulate/Class/Accessor/Fast.pm b/lib/MooseX/Emulate/Class/Accessor/Fast.pm
index c75cf30..64955d6 100644
--- a/lib/MooseX/Emulate/Class/Accessor/Fast.pm
+++ b/lib/MooseX/Emulate/Class/Accessor/Fast.pm
@@ -2,7 +2,7 @@ package MooseX::Emulate::Class::Accessor::Fast;
 
 use Moose::Role;
 
-our $VERSION = '0.00200';
+our $VERSION = '0.00300';
 
 =head1 NAME
 
@@ -12,7 +12,7 @@ MooseX::Emulate::Class::Accessor::Fast -
 =head1 SYNOPSYS
 
     package MyClass;
-    Use Moose;
+    use Moose;
 
     with 'MooseX::Emulate::Class::Accessor::Fast';
 
@@ -60,27 +60,25 @@ methods in L<Class::MOP::Attribute>. Example
 
 =head1 METHODS
 
-=head2 new %args
+=head2 BUILD $self %args
 
-Extend the default Moose constructor to emulate the behavior of C::A::F and
+Change the default Moose class building to emulate the behavior of C::A::F and
 store arguments in the instance hashref.
 
 =cut
 
-around new => sub{
-  my $orig = shift;
-  my $class = shift;
+sub BUILD {
+  my $self = shift;
   my %args;
   if (scalar @_ == 1 && defined $_[0] && ref($_[0]) eq 'HASH') {
     %args = %{$_[0]};
   } else {
     %args = @_;
   }
-  my $self = $class->$orig(@_);
   my @extra = grep { !exists($self->{$_}) } keys %args;
   @{$self}{@extra} = @args{@extra};
   return $self;
-};
+}
 
 =head2 mk_accessors @field_names
 
diff --git a/t/construction.t b/t/construction.t
new file mode 100644
index 0000000..2c07602
--- /dev/null
+++ b/t/construction.t
@@ -0,0 +1,71 @@
+#!perl
+use strict;
+use Test::More tests => 9;
+
+#1
+require_ok("MooseX::Emulate::Class::Accessor::Fast");
+
+{
+  package MyClass;
+  use Moose;
+  with 'MooseX::Emulate::Class::Accessor::Fast';
+}
+
+{
+  package MyClass::MooseChild;
+  use Moose;
+  extends 'MyClass';
+}
+
+{
+  package MyClass::ImmutableMooseChild;
+  use Moose;
+  extends 'MyClass';
+  __PACKAGE__->meta->make_immutable;
+}
+
+{
+  package MyClass::TraditionalChild;
+  use base qw(MyClass);
+}
+
+{
+  package MyImmutableClass;
+  use Moose;
+  with 'MooseX::Emulate::Class::Accessor::Fast';
+  __PACKAGE__->meta->make_immutable;
+}
+
+{
+  package MyImmutableClass::MooseChild;
+  use Moose;
+  extends 'MyImmutableClass';
+}
+
+{
+  package MyImmutableClass::ImmutableMooseChild;
+  use Moose;
+  extends 'MyImmutableClass';
+  __PACKAGE__->meta->make_immutable;
+}
+
+{
+  package MyImmutableClass::TraditionalChild;
+  use base qw(MyImmutableClass);
+}
+
+# 2-9
+foreach my $class (qw/
+                      MyClass 
+                      MyImmutableClass 
+                      MyClass::MooseChild 
+                      MyClass::ImmutableMooseChild  
+                      MyClass::TraditionalChild 
+                      MyImmutableClass::MooseChild 
+                      MyImmutableClass::ImmutableMooseChild 
+                      MyImmutableClass::TraditionalChild
+                                                           /) {
+    my $instance = $class->new(foo => 'bar');
+    is($instance->{foo}, 'bar', $class . " has CAF construction behavior");
+}
+