From: Matt S Trout <mst@shadowcat.co.uk>
Date: Thu, 3 May 2012 19:09:13 +0000 (+0000)
Subject: first cut at extension tests
X-Git-Tag: v0.091002~13
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=873df57040580aff36452de31e310003f73390fc;hp=ceea0e3806c6b5e700ff9ac8d4cfb36bc1c20af9;p=gitmo%2FMoo.git

first cut at extension tests
---

diff --git a/lib/Method/Generate/Accessor.pm b/lib/Method/Generate/Accessor.pm
index 5636aac..d315818 100644
--- a/lib/Method/Generate/Accessor.pm
+++ b/lib/Method/Generate/Accessor.pm
@@ -46,7 +46,7 @@ sub generate_method {
   if (my $reader = $spec->{reader}) {
     if (our $CAN_HAZ_XS && $self->is_simple_get($name, $spec)) {
       $methods{$reader} = $self->_generate_xs(
-        getters => $into, $reader, $name
+        getters => $into, $reader, $name, $spec
       );
     } else {
       $self->{captures} = {};
@@ -65,7 +65,7 @@ sub generate_method {
       && $self->is_simple_set($name, $spec)
     ) {
       $methods{$accessor} = $self->_generate_xs(
-        accessors => $into, $accessor, $name
+        accessors => $into, $accessor, $name, $spec
       );
     } else {
       $self->{captures} = {};
@@ -82,7 +82,7 @@ sub generate_method {
       && $self->is_simple_set($name, $spec)
     ) {
       $methods{$writer} = $self->_generate_xs(
-        setters => $into, $writer, $name
+        setters => $into, $writer, $name, $spec
       );
     } else {
       $self->{captures} = {};
@@ -390,10 +390,16 @@ sub generate_multi_set {
   "\@{${me}}{qw(${\join ' ', @$to_set})} = $from";
 }
 
+sub _generate_core_set {
+  my ($self, $me, $name, $spec, $value) = @_;
+  my $name_str = perlstring $name;
+  "${me}->{${name_str}} = ${value}";
+}
+
 sub _generate_simple_set {
   my ($self, $me, $name, $spec, $value) = @_;
   my $name_str = perlstring $name;
-  my $simple = "${me}->{${name_str}} = ${value}";
+  my $simple = $self->_generate_core_set($self, $me, $name, $spec, $value);
 
   if ($spec->{weak_ref}) {
     require Scalar::Util;
diff --git a/lib/Moo/Role.pm b/lib/Moo/Role.pm
index a8884de..fb82079 100644
--- a/lib/Moo/Role.pm
+++ b/lib/Moo/Role.pm
@@ -117,7 +117,7 @@ sub create_class_with_roles {
   $Moo::MAKERS{$new_name} = {};
 
   $me->_handle_constructor(
-    $new_name, [ map @{$INFO{$_}{attributes}||{}}, @roles ], $superclass
+    $new_name, [ map @{$INFO{$_}{attributes}||[]}, @roles ], $superclass
   );
 
   return $new_name;
diff --git a/t/accessor-generator-extension.t b/t/accessor-generator-extension.t
new file mode 100644
index 0000000..3164bf6
--- /dev/null
+++ b/t/accessor-generator-extension.t
@@ -0,0 +1,82 @@
+use strictures 1;
+use Test::More;
+
+BEGIN {
+  package Method::Generate::Accessor::Role::ArrayRefInstance;
+
+  use Moo::Role;
+
+  sub _generate_simple_get {
+    my ($self, $me, $name, $spec) = @_;
+    "${me}->[${\$spec->{index}}]";
+  }
+
+  sub _generate_core_set {
+    my ($self, $me, $name, $spec, $value) = @_;
+    "${me}->[${\$spec->{index}}] = $value";
+  }
+
+  sub _generate_simple_has {
+    my ($self, $me, $name, $spec) = @_;
+    "defined ${me}->[${\$spec->{index}}]";
+  }
+
+  sub _generate_simple_clear {
+    my ($self, $me, $name, $spec) = @_;
+    "undef(${me}->[${\$spec->{index}}])";
+  }
+
+  sub generate_multi_set {
+    my ($self, $me, $to_set, $from, $specs) = @_;
+    "\@{${me}}[${\join ', ', map $specs->{$_}{index}, @$to_set}] = $from";
+  }
+
+  sub _generate_xs {
+    my ($self, $type, $into, $name, $slot, $spec) = @_;
+    require Class::XSAccessor::Array;
+    Class::XSAccessor::Array->import(
+      class => $into,
+      $type => { $name => $spec->{index} }
+    );
+    $into->can($name);
+  }
+
+  sub default_construction_string { '[]' }
+}
+
+{
+  package ArrayTest1;
+
+  use Moo;
+
+  BEGIN {
+     Moo::Role->apply_roles_to_object(
+       Moo->_accessor_maker_for(__PACKAGE__),
+      'Method::Generate::Accessor::Role::ArrayRefInstance'
+     )
+  }
+
+  has one => (is => 'ro');
+  has two => (is => 'ro');
+  has three => (is => 'ro');
+}
+
+my $o = ArrayTest1->new(one => 1, two => 2, three => 3);
+
+is_deeply([ @$o ], [ 1, 2, 3 ], 'Basic object ok');
+
+{
+  package ArrayTest2;
+
+  use Moo;
+
+  extends 'ArrayTest1';
+
+  has four => (is => 'ro');
+}
+
+$o = ArrayTest2->new(one => 1, two => 2, three => 3, four => 4);
+
+is_deeply([ @$o ], [ 1, 2, 3, 4 ], 'Subclass object ok');
+
+done_testing;