From: Tomas Doran <bobtfish@bobtfish.net>
Date: Mon, 29 Dec 2008 16:45:18 +0000 (+0000)
Subject: Add all my extra tests, and fix some of them
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=330a3f6b5a4026b2b2333afb6fd7ccad031942b4;p=gitmo%2FMooseX-Emulate-Class-Accessor-Fast.git

Add all my extra tests, and fix some of them
---

diff --git a/lib/MooseX/Emulate/Class/Accessor/Fast.pm b/lib/MooseX/Emulate/Class/Accessor/Fast.pm
index 0f1fbdd..ca6d4e2 100644
--- a/lib/MooseX/Emulate/Class/Accessor/Fast.pm
+++ b/lib/MooseX/Emulate/Class/Accessor/Fast.pm
@@ -3,6 +3,9 @@ package MooseX::Emulate::Class::Accessor::Fast;
 use Moose::Role;
 use Class::MOP ();
 use Scalar::Util ();
+use Carp ();
+
+use MooseX::Emulate::Class::Accessor::Fast::Meta::Accessor ();
 
 our $VERSION = '0.00600';
 
@@ -75,6 +78,19 @@ my $locate_metaclass = sub {
     || Moose::Meta::Class->initialize($class);
 };
 
+my $reopen_package_if_needed = sub {
+  my $self = shift;
+  my $meta = $locate_metaclass->($self);
+  my $immutable = $meta->is_immutable;
+  if ($immutable) {
+    $meta->make_mutable;
+    my $class = Scalar::Util::blessed($self) || $self;
+    Carp::cluck("Class $class was immutable, but needs to be re-opened!");
+    return sub { $meta->make_immutable; };
+  }
+  return sub {};
+};
+
 sub BUILD {
   my $self = shift;
   my %args;
@@ -102,6 +118,7 @@ will be passed. Please see L<Class::MOP::Attribute> for more information.
 sub mk_accessors{
   my $self = shift;
   my $meta = $locate_metaclass->($self);
+  my $reclose = $reopen_package_if_needed->($self);
   for my $attr_name (@_){
     my $reader = $self->accessor_name_for($attr_name);
     my $writer = $self->mutator_name_for( $attr_name);
@@ -109,7 +126,9 @@ sub mk_accessors{
     #dont overwrite existing methods
     if($reader eq $writer){
       my %opts = ( $meta->has_method($reader) ? () : (accessor => $reader) );
-      my $attr = $meta->add_attribute($attr_name, %opts);
+      my $attr = $meta->find_attribute_by_name($attr_name) || $meta->add_attribute($attr_name, %opts, 
+        traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+      );
       if($attr_name eq $reader){
         my $alias = "_${attr_name}_accessor";
         next if $meta->has_method($alias);
@@ -119,9 +138,12 @@ sub mk_accessors{
     } else {
       my @opts = ( $meta->has_method($writer) ? () : (writer => $writer) );
       push(@opts, (reader => $reader)) unless $meta->has_method($reader);
-      $meta->add_attribute($attr_name, @opts);
+      my $attr = $meta->find_attribute_by_name($attr_name) || $meta->add_attribute($attr_name, @opts, 
+        traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+      );
     }
   }
+  $reclose->();
 }
 
 =head2 mk_ro_accessors @field_names
@@ -133,15 +155,19 @@ Create read-only accessors.
 sub mk_ro_accessors{
   my $self = shift;
   my $meta = $locate_metaclass->($self);
+  my $reclose = $reopen_package_if_needed->($self);
   for my $attr_name (@_){
     my $reader = $self->accessor_name_for($attr_name);
     my @opts = ($meta->has_method($reader) ? () : (reader => $reader) );
-    my $attr = $meta->add_attribute($attr_name, @opts);
+    my $attr = $meta->add_attribute($attr_name, @opts, 
+      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+    ) if scalar(@opts);
     if($reader eq $attr_name && $reader eq $self->mutator_name_for($attr_name)){
       $meta->add_method("_${attr_name}_accessor" => $attr->get_read_method_ref)
         unless $meta->has_method("_${attr_name}_accessor");
     }
   }
+  $reclose->();
 }
 
 =head2 mk_ro_accessors @field_names
@@ -154,15 +180,19 @@ Create write-only accessors.
 sub mk_wo_accessors{
   my $self = shift;
   my $meta = $locate_metaclass->($self);
+  my $reclose = $reopen_package_if_needed->($self);
   for my $attr_name (@_){
     my $writer = $self->mutator_name_for($attr_name);
     my @opts = ($meta->has_method($writer) ? () : (writer => $writer) );
-    my $attr = $meta->add_attribute($attr_name, @opts);
+    my $attr = $meta->add_attribute($attr_name, @opts, 
+      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+    ) if scalar(@opts);
     if($writer eq $attr_name && $writer eq $self->accessor_name_for($attr_name)){
       $meta->add_method("_${attr_name}_accessor" => $attr->get_write_method_ref)
         unless $meta->has_method("_${attr_name}_accessor");
     }
   }
+  $reclose->();
 }
 
 =head2 follow_best_practices
@@ -175,11 +205,13 @@ See original L<Class::Accessor> documentation for more information.
 sub follow_best_practice{
   my $self = shift;
   my $meta = $locate_metaclass->($self);
+  my $reclose = $reopen_package_if_needed->($self);
 
   $meta->remove_method('mutator_name_for');
   $meta->remove_method('accessor_name_for');
   $meta->add_method('mutator_name_for',  sub{ return "set_".$_[1] });
   $meta->add_method('accessor_name_for', sub{ return "get_".$_[1] });
+  $reclose->();
 }
 
 =head2 mutator_name_for
@@ -208,7 +240,7 @@ sub set{
   confess "No such attribute  '$k'"
     unless ( my $attr = $meta->find_attribute_by_name($k) );
   my $writer = $attr->get_write_method;
-  $self->$writer(@_ > 1 ? [@_] : @_);
+  $self->$writer(@_);
 }
 
 =head2 get
@@ -236,30 +268,45 @@ sub get{
 sub make_accessor {
   my($class, $field) = @_;
   my $meta = $locate_metaclass->($class);
-  my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field); 
+  my $reclose = $reopen_package_if_needed->($class);
+  my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field, 
+      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+  ); 
   my $reader = $attr->get_read_method_ref;
   my $writer = $attr->get_write_method_ref;
-  return sub {
+  my $accessor = sub {
     my $self = shift;
     return $reader->($self) unless @_;
     return $writer->($self,(@_ > 1 ? [@_] : @_));
-  }
+  };
+  $reclose->();
+  return $accessor;
 }
 
 
 sub make_ro_accessor {
   my($class, $field) = @_;
   my $meta = $locate_metaclass->($class);
-  my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field); 
-  return $attr->get_read_method_ref;
+  my $reclose = $reopen_package_if_needed->($class);
+  my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field, 
+      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+  ); 
+  my $method_ref = $attr->get_read_method_ref;
+  $reclose->();
+  return $method_ref;
 }
 
 
 sub make_wo_accessor {
   my($class, $field) = @_;
   my $meta = $locate_metaclass->($class);
-  my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field); 
-  return $attr->get_write_method_ref;
+  my $reclose = $reopen_package_if_needed->($class);
+  my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field, 
+      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+  ); 
+  my $method_ref = $attr->get_write_method_ref;
+  $reclose->();
+  return $method_ref;
 }
 
 1;
diff --git a/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Accessor.pm b/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Accessor.pm
new file mode 100644
index 0000000..f663907
--- /dev/null
+++ b/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Accessor.pm
@@ -0,0 +1,47 @@
+package MooseX::Emulate::Class::Accessor::Fast::Meta::Accessor;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+use base 'Moose::Meta::Method::Accessor';
+
+sub generate_accessor_method {
+    my $attr = (shift)->associated_attribute;
+    return sub {
+        my $self = shift;
+        $attr->set_value($self, $_[0]) if scalar(@_) == 1;
+        $attr->set_value($self, [@_]) if scalar(@_) > 1;
+        $attr->get_value($self);
+    };
+}
+
+sub generate_writer_method {
+    my $attr = (shift)->associated_attribute;
+    return sub {
+        my $self = shift;
+        $attr->set_value($self, $_[0]) if scalar(@_) == 1;
+        $attr->set_value($self, [@_]) if scalar(@_) > 1;
+    };
+}
+
+# FIXME - this is shite, but it does work...
+sub generate_accessor_method_inline {
+    my $attr          = (shift)->associated_attribute;
+    my $attr_name     = $attr->name;
+    my $meta_instance = $attr->associated_class->instance_metaclass;#
+
+    my $code = eval "sub {
+        my \$self = shift;
+        \$self->{'$attr_name'} = \$_[0] if scalar(\@_) == 1;
+        \$self->{'$attr_name'} = [\@_] if scalar(\@_) > 1;
+        \$self->{'$attr_name'};
+    }";
+    confess "Could not generate inline accessor because : $@" if $@;
+
+    return $code;
+}
+*generate_writer_method_inline = \&generate_accessor_method_inline;
+
+1;
diff --git a/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Role/Attribute.pm b/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Role/Attribute.pm
new file mode 100644
index 0000000..4941f1f
--- /dev/null
+++ b/lib/MooseX/Emulate/Class/Accessor/Fast/Meta/Role/Attribute.pm
@@ -0,0 +1,6 @@
+package MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute;
+use Moose::Role;
+
+sub accessor_metaclass { 'MooseX::Emulate::Class::Accessor::Fast::Meta::Accessor' }
+
+1;
diff --git a/t/accessors.t b/t/accessors.t
index 04efe4b..b0162ac 100644
--- a/t/accessors.t
+++ b/t/accessors.t
@@ -25,6 +25,7 @@ my $class = "Testing::Class::Accessor::Fast";
     }
   );
 
+  $meta->make_immutable;
   $class->mk_accessors(qw( foo bar yar car mar test));
   $class->mk_ro_accessors(qw(static unchanged));
   $class->mk_wo_accessors(qw(sekret double_sekret));
diff --git a/t/class_accessor_chained_fast.t b/t/class_accessor_chained_fast.t
new file mode 100644
index 0000000..7e47915
--- /dev/null
+++ b/t/class_accessor_chained_fast.t
@@ -0,0 +1,34 @@
+use MooseX::Adopt::Class::Accessor::Fast;
+use Test::More tests => 1;
+
+{
+  package Class::Accessor::Chained::Fast;
+  use strict;
+  use base 'Class::Accessor::Fast';
+
+  sub make_accessor {
+    my($class, $field) = @_;
+
+    return sub {
+      my $self = shift;
+      if(@_) {
+        $self->{$field} = (@_ == 1 ? $_[0] : [@_]);
+        return $self;
+      }
+      return $self->{$field};
+    };
+  }
+}
+
+{
+   package TestPackage;
+   use base qw/Class::Accessor::Chained::Fast/;
+   __PACKAGE__->mk_accessors('foo');
+}
+
+my $i = bless {}, 'TestPackage';
+my $other_i = $i->foo('bar');
+TODO: {
+  local $TODO = 'ENOWORKEY';
+  is($other_i, $i, 'Accessor returns instance as opposed to value.');
+}
diff --git a/t/double_apply.t b/t/double_apply.t
new file mode 100644
index 0000000..11fdc8a
--- /dev/null
+++ b/t/double_apply.t
@@ -0,0 +1,30 @@
+#!perl
+use strict;
+use Test::More tests => 5;
+use Test::Exception;
+
+# 1
+use_ok('MooseX::Adopt::Class::Accessor::Fast');
+{
+  package My::Package;
+  use base qw/Class::Accessor::Fast/;
+  for (0..1) {
+    __PACKAGE__->mk_accessors(qw( foo ));
+    __PACKAGE__->mk_ro_accessors(qw( bar ));
+    __PACKAGE__->mk_wo_accessors(qw( baz ));
+  }
+}
+
+my $i = bless { bar => 'bar' }, 'My::Package';
+
+# 2
+lives_ok {
+  $i->foo('foo');
+  $i->baz('baz');
+
+  # 3-5
+  is($i->foo, 'foo');
+  is($i->bar, 'bar');
+  is($i->{baz}, 'baz');
+} 'No exception';
+
diff --git a/t/list_assign.t b/t/list_assign.t
new file mode 100644
index 0000000..033382c
--- /dev/null
+++ b/t/list_assign.t
@@ -0,0 +1,19 @@
+use MooseX::Adopt::Class::Accessor::Fast;
+
+{
+  package Some::Class;
+  use strict;
+  use warnings;
+  use base qw/Class::Accessor::Fast/;
+
+  __PACKAGE__->mk_accessors(qw/ foo /);
+}
+
+package main;
+use strict;
+use Test::More tests => 1;
+my $i = bless {}, 'Some::Class';
+$i->foo(qw/bar baz/);
+is_deeply($i->foo, [qw/ bar baz /]);
+
+
diff --git a/t/reopen_package.t b/t/reopen_package.t
new file mode 100644
index 0000000..ceac86a
--- /dev/null
+++ b/t/reopen_package.t
@@ -0,0 +1,32 @@
+use Test::More tests => 9;
+use Test::Exception;
+
+# 1
+BEGIN { require_ok("MooseX::Adopt::Class::Accessor::Fast"); }
+
+use Class::MOP;
+use Class::Accessor::Fast;
+@My::Class::ISA = 'Class::Accessor::Fast';
+my $meta = Class::MOP::get_metaclass_by_name('My::Class') 
+  || Class::MOP::Class->initialize('My::Class');
+$meta->make_immutable;
+
+my @warnings;
+$SIG{__WARN__} = sub { push(@warnings, shift) };
+
+# 2-4
+lives_ok { My::Class->mk_accessors('foo') } 'mk_accessors on immutable';
+lives_ok { My::Class->mk_ro_accessors('quux') } 'mk_ro_accessors on immutable';
+lives_ok { My::Class->mk_wo_accessors('flibble') } 'mk_wo_accessors on immutable';
+
+# 5-7
+lives_ok { My::Class->make_accessor('bar') } 'mk_accessor on immutable';
+lives_ok { My::Class->make_ro_accessor('gong') } 'mk_ro_accessor on immutable';
+lives_ok { My::Class->make_wo_accessor('wibble') } 'mk_wo_accessor on immutable';
+
+# 8
+lives_ok { My::Class->follow_best_practice } 'follow_best_practice on immutable';
+
+# 9
+is( scalar(@warnings), 7, '7 warnings' );
+