From: Guillermo Roditi <groditi@gmail.com>
Date: Wed, 17 Dec 2008 20:00:27 +0000 (+0000)
Subject: (no commit message)
X-Git-Tag: 0.00700~4
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5a6e3389d072389c7d9a798a1b35c4cfa86012f3;p=gitmo%2FMooseX-Emulate-Class-Accessor-Fast.git

---

diff --git a/Changes b/Changes
index bae4593..6672b31 100644
--- a/Changes
+++ b/Changes
@@ -1,8 +1,11 @@
-0.00600
+0.00600    Dec 17, 2008
           - Add test for a 'meta' accessor, which we need to treat as a 
             special case (t0m)
           - Add test for not replacing pre-existing accessors generally, 
             which is behavior we don't want to lose (t0m)
+          - Don't use ->meta
+          - Don't use ->can
+          - Attempt to support attrs named meta with no success. test marked as todo.
 0.00500    Dec 9, 2008
           - make_accessor, make_ro_accessor, make_rw_accessor
             - tests
diff --git a/lib/MooseX/Adopt/Class/Accessor/Fast.pm b/lib/MooseX/Adopt/Class/Accessor/Fast.pm
index 066f424..44b4de4 100644
--- a/lib/MooseX/Adopt/Class/Accessor/Fast.pm
+++ b/lib/MooseX/Adopt/Class/Accessor/Fast.pm
@@ -8,6 +8,7 @@ package #don't index
     Class::Accessor::Fast;
 
 use Moose;
+use namespace::clean;
 with 'MooseX::Emulate::Class::Accessor::Fast';
 
 1;
diff --git a/lib/MooseX/Emulate/Class/Accessor/Fast.pm b/lib/MooseX/Emulate/Class/Accessor/Fast.pm
index b119aa5..0f1fbdd 100644
--- a/lib/MooseX/Emulate/Class/Accessor/Fast.pm
+++ b/lib/MooseX/Emulate/Class/Accessor/Fast.pm
@@ -1,8 +1,10 @@
 package MooseX::Emulate::Class::Accessor::Fast;
 
 use Moose::Role;
+use Class::MOP ();
+use Scalar::Util ();
 
-our $VERSION = '0.00500';
+our $VERSION = '0.00600';
 
 =head1 NAME
 
@@ -67,6 +69,12 @@ store arguments in the instance hashref.
 
 =cut
 
+my $locate_metaclass = sub {
+  my $class = Scalar::Util::blessed($_[0]) || $_[0];
+  return Class::MOP::get_metaclass_by_name($class)
+    || Moose::Meta::Class->initialize($class);
+};
+
 sub BUILD {
   my $self = shift;
   my %args;
@@ -93,25 +101,24 @@ will be passed. Please see L<Class::MOP::Attribute> for more information.
 
 sub mk_accessors{
   my $self = shift;
-  my $meta = $self->meta;
+  my $meta = $locate_metaclass->($self);
   for my $attr_name (@_){
     my $reader = $self->accessor_name_for($attr_name);
     my $writer = $self->mutator_name_for( $attr_name);
 
     #dont overwrite existing methods
     if($reader eq $writer){
-      my %opts = ( $self->can($reader) ? () : (accessor => $reader) );
+      my %opts = ( $meta->has_method($reader) ? () : (accessor => $reader) );
       my $attr = $meta->add_attribute($attr_name, %opts);
       if($attr_name eq $reader){
         my $alias = "_${attr_name}_accessor";
-        next if $self->can($alias);
-        my @alias_method = $opts{accessor} ? ( $alias => $self->can($reader) )
-          : ( $attr->process_accessors(accessor => $alias, 0 ) );
+        next if $meta->has_method($alias);
+        my @alias_method = $attr->process_accessors(accessor => $alias, 0);
         $meta->add_method(@alias_method);
       }
     } else {
-      my @opts = ( $self->can($writer) ? () : (writer => $writer) );
-      push(@opts, (reader => $reader)) unless $self->can($reader);
+      my @opts = ( $meta->has_method($writer) ? () : (writer => $writer) );
+      push(@opts, (reader => $reader)) unless $meta->has_method($reader);
       $meta->add_attribute($attr_name, @opts);
     }
   }
@@ -125,14 +132,14 @@ Create read-only accessors.
 
 sub mk_ro_accessors{
   my $self = shift;
-  my $meta = $self->meta;
+  my $meta = $locate_metaclass->($self);
   for my $attr_name (@_){
     my $reader = $self->accessor_name_for($attr_name);
-    my @opts = ($self->can($reader) ? () : (reader => $reader) );
+    my @opts = ($meta->has_method($reader) ? () : (reader => $reader) );
     my $attr = $meta->add_attribute($attr_name, @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 $self->can("_${attr_name}_accessor");
+        unless $meta->has_method("_${attr_name}_accessor");
     }
   }
 }
@@ -146,14 +153,14 @@ Create write-only accessors.
 #this is retarded.. but we need it for compatibility or whatever.
 sub mk_wo_accessors{
   my $self = shift;
-  my $meta = $self->meta;
+  my $meta = $locate_metaclass->($self);
   for my $attr_name (@_){
     my $writer = $self->mutator_name_for($attr_name);
-    my @opts = ($self->can($writer) ? () : (writer => $writer) );
+    my @opts = ($meta->has_method($writer) ? () : (writer => $writer) );
     my $attr = $meta->add_attribute($attr_name, @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 $self->can("_${attr_name}_accessor");
+        unless $meta->has_method("_${attr_name}_accessor");
     }
   }
 }
@@ -167,7 +174,7 @@ See original L<Class::Accessor> documentation for more information.
 
 sub follow_best_practice{
   my $self = shift;
-  my $meta = $self->meta;
+  my $meta = $locate_metaclass->($self);
 
   $meta->remove_method('mutator_name_for');
   $meta->remove_method('accessor_name_for');
@@ -196,11 +203,11 @@ sub set{
   my $self = shift;
   my $k = shift;
   confess "Wrong number of arguments received" unless scalar @_;
+  my $meta = $locate_metaclass->($self);
 
-  #my $writer = $self->mutator_name_for( $k );
   confess "No such attribute  '$k'"
-    unless ( my $attr = $self->meta->find_attribute_by_name($k) );
-  my $writer = $attr->writer || $attr->accessor;
+    unless ( my $attr = $meta->find_attribute_by_name($k) );
+  my $writer = $attr->get_write_method;
   $self->$writer(@_ > 1 ? [@_] : @_);
 }
 
@@ -213,13 +220,13 @@ See original L<Class::Accessor> documentation for more information.
 sub get{
   my $self = shift;
   confess "Wrong number of arguments received" unless scalar @_;
-
+  my $meta = $locate_metaclass->($self);
   my @values;
-  #while( my $attr = $self->meta->find_attribute_by_name( shift(@_) ){
+
   for( @_ ){
     confess "No such attribute  '$_'"
-      unless ( my $attr = $self->meta->find_attribute_by_name($_) );
-    my $reader = $attr->reader || $attr->accessor;
+      unless ( my $attr = $meta->find_attribute_by_name($_) );
+    my $reader = $attr->get_read_method;
     @_ > 1 ? push(@values, $self->$reader) : return $self->$reader;
   }
 
@@ -228,7 +235,7 @@ sub get{
 
 sub make_accessor {
   my($class, $field) = @_;
-  my $meta = $class->meta;
+  my $meta = $locate_metaclass->($class);
   my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field); 
   my $reader = $attr->get_read_method_ref;
   my $writer = $attr->get_write_method_ref;
@@ -242,7 +249,7 @@ sub make_accessor {
 
 sub make_ro_accessor {
   my($class, $field) = @_;
-  my $meta = $class->meta;
+  my $meta = $locate_metaclass->($class);
   my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field); 
   return $attr->get_read_method_ref;
 }
@@ -250,12 +257,11 @@ sub make_ro_accessor {
 
 sub make_wo_accessor {
   my($class, $field) = @_;
-  my $meta = $class->meta;
+  my $meta = $locate_metaclass->($class);
   my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field); 
   return $attr->get_write_method_ref;
 }
 
-
 1;
 
 =head2 meta
diff --git a/t/attr_named_meta.t b/t/attr_named_meta.t
new file mode 100644
index 0000000..f12c9be
--- /dev/null
+++ b/t/attr_named_meta.t
@@ -0,0 +1,30 @@
+#!/usr/bin/perl -w
+
+use strict;
+use warnings;
+use Class::MOP ();
+use Test::More skip_all => 'TODO'; #
+use MooseX::Adopt::Class::Accessor::Fast;
+
+{
+  package TestPackage;
+  use base 'Class::Accessor::Fast';
+  __PACKAGE__->mk_accessors(qw/ meta /);
+}
+
+my $i = TestPackage->new( meta => 66 );
+
+is $i->meta, 66, 'meta accessor read value from constructor';
+$i->meta(9);
+is $i->meta, 9, 'meta accessor read set value';
+
+my $meta = Class::MOP::get_metaclass_for('TestPackage');
+$meta->make_immutable;
+
+is $i->meta, 9, 'meta accessor read value from constructor';
+$i->meta(66);
+is $i->meta, 66, 'meta accessor read set value';
+
+
+__END__;
+
diff --git a/t/meta.t b/t/meta.t
deleted file mode 100644
index 71ce297..0000000
--- a/t/meta.t
+++ /dev/null
@@ -1,138 +0,0 @@
-use strict;
-use warnings;
-use Test::More tests => 12;
-use MooseX::Adopt::Class::Accessor::Fast;
-{
-  package TestPackage;
-  use Moose;
-  with 'MooseX::Emulate::Class::Accessor::Fast';
-  __PACKAGE__->mk_accessors(qw/ normal /);
-  __PACKAGE__->meta->make_immutable;
-}
-{
-  package TestPackage::SubClass::Accessors;
-  use base qw/TestPackage/;
-  __PACKAGE__->mk_accessors(qw/ meta /);
-}
-{
-  package TestPackage::SubClass::Readonly;
-  use base qw/TestPackage/;
-  __PACKAGE__->mk_ro_accessors(qw/ meta /);
-}
-{
-  package TestPackage::SubClass::Writeonly;
-  use base qw/TestPackage/;
-  __PACKAGE__->mk_wo_accessors(qw(sekret double_sekret));
-}
-
-# This setup is a _specific_ example from Catalyst.
-
-# CAF _will not_ replace a pre-existing symbol, but there never
-# used to be a 'meta' symbol before CAF things are ported to Moose
-
-# Therefore, 'meta' needs to be treated as a special case, as
-# code which is _not_ using the symbol already should be allowed to
-# say $self->meta, and get all the Moose goodness, but code which
-# makes an accessor called ->meta should still work!
-
-# 22:22 <@groditi> the difference is meta wasnt there as a method before, but MooseX::Adopt::CAF does have a meta method.
-# 22:23 <@groditi> i guess i could namespace::clean it out. but it might create confusion
-# 22:23  * t0m nod - I think we need a special case for this..
-# 22:23 <@groditi> mst: thoughts?
-# 22:23 <@mst> Moose needs to not export 'meta' if you don't want it
-# 22:24 <@groditi> so namespace::clean it out or what?
-# 22:25 <@mst> hmm
-# 22:25 <@mst> does ->mk_accessors(qw(meta)) work if you do "use base qw(...)" instead of use Moose ?
-# 22:26 <@mst> if it doesn't, then it isn't a bug in CAF
-# 22:27 <@groditi> its my bug. because Adopt does use Moose because Emulate is a role
-# 22:27 <@groditi> so if you isa CAF then you definitely can(meta)
-# 22:27 <@t0m> I think that if the user makes an accessor called 'meta', we need to remove the Moose package symbol, and 
-#              immutable the class so the the accessor / constructor doesn't touch meta..
-# 22:27 <@t0m> and generate a warning.
-# 22:28 <@t0m> which is ugly as, but kinda works.
-# 22:29 <@groditi> ok ok. i'll do has_method
-# 22:29 <@t0m> as you want users who aren't shitting on the moose symbol to be able to call $self->meta as they 'Moosify'
-# 22:29 <@groditi> this sucks though because Emulate counts on meta being there
-# 22:30 <@groditi> ok well this requires major major changes so delayed until i finish finals
-
-# Suggested fix - something less hacky than:
-#Index: lib/MooseX/Emulate/Class/Accessor/Fast.pm
-#===================================================================
-#--- lib/MooseX/Emulate/Class/Accessor/Fast.pm   (revision 7035)
-#+++ lib/MooseX/Emulate/Class/Accessor/Fast.pm   (working copy)
-#@@ -93,14 +93,15 @@
-# 
-# sub mk_accessors{
-#   my $self = shift;
-#-  my $meta = $self->meta;
-#+  my $meta = $self->Moose::Object::meta;
-#+  $meta->make_mutable if $meta->is_immutable;
-#   for my $attr_name (@_){
-#     my $reader = $self->accessor_name_for($attr_name);
-#     my $writer = $self->mutator_name_for( $attr_name);
-# 
-#     #dont overwrite existing methods
-#     if($reader eq $writer){
-#-      my %opts = ( $self->can($reader) ? () : (accessor => $reader) );
-#+      my %opts = ( $self->can($reader) && $reader ne 'meta' ? () : (accessor => $reader) );
-#       my $attr = $meta->add_attribute($attr_name, %opts);
-#       if($attr_name eq $reader){
-#         my $alias = "_${attr_name}_accessor";
-#@@ -115,6 +116,7 @@
-#       $meta->add_attribute($attr_name, @opts);
-#     }
-#   }
-#+  $meta->make_immutable;
-# }
-
-{
-  my $i = TestPackage::SubClass::Accessors->new({ normal => 42, meta => 66 });
-
-  # 1,2
-  is $i->normal, 42, 'normal accessor read value from constructor';
-  $i->normal(2);
-  is $i->normal, 2, 'normal accessor read set value';
-
-  TODO: {
-    local $TODO = 'meta method needs special case';
-
-    # 3,4
-    is $i->meta, 66, 'meta accessor read value from constructor';
-    $i->meta(9);
-    is $i->meta, 9, 'meta accessor read set value';
-  }
-}
-{
-  my $i = TestPackage::SubClass::Readonly->new({ normal => 42, meta => 66 });
-
-  # 5,6
-  is $i->normal, 42, 'normal accessor read value from constructor';
-  $i->{normal} = 2;
-  is $i->normal, 2, 'normal accessor read set value';
-
-  TODO: {
-    local $TODO = 'meta method needs special case';
-    
-    # 7,8
-    is $i->meta, 66, 'meta accessor read value from constructor';
-    $i->{meta} = 9;
-    is $i->meta, 9, 'meta accessor read set value';
-  }
-}
-{
-  my $i = TestPackage::SubClass::Writeonly->new({ normal => 42, meta => 66 });
-
-  # 9,10
-  is $i->normal, 42, 'normal accessor read value from constructor';
-  $i->normal(2);
-  is $i->normal, 2, 'normal accessor read set value';
-
-  TODO: {
-    local $TODO = 'meta method needs special case';
-
-    # 11,12
-    is $i->{meta}, 66, 'meta accessor read value from constructor';
-    $i->meta(9);
-    is $i->{meta}, 9, 'meta accessor read set value';
-  }
-}
diff --git a/t/no_replace_existing_symbols.t b/t/no_replace_existing_symbols.t
index e59da3a..a5867ec 100644
--- a/t/no_replace_existing_symbols.t
+++ b/t/no_replace_existing_symbols.t
@@ -1,12 +1,16 @@
+#!/usr/binperl -w
+
+use strict;
+use warnings;
+use Test::More tests => 6;
+
 {
   package SomeClass;
-  #use base qw/Class::Accessor::Fast/;
   use Moose;
   with 'MooseX::Emulate::Class::Accessor::Fast';
-  
+
   sub anaccessor { 'wibble' }
 
-  #sub new { bless {}, 'SomeClass' }
 }
 {
   package SubClass;
@@ -16,19 +20,17 @@
   __PACKAGE__->mk_accessors(qw/ anaccessor anotherone /);
 }
 
-use Test::More tests => 6;
-
 # 1, 2
 my $someclass = SomeClass->new;
-is $someclass->anaccessor, 'wibble';
+is($someclass->anaccessor, 'wibble');
 $someclass->anaccessor('fnord');
-is $someclass->anaccessor, 'wibble';
+is($someclass->anaccessor, 'wibble');
 
 # 3-6
 my $subclass = SubClass->new;
-is $subclass->anaccessor, 'wibble';
+ok( not defined $subclass->anaccessor );
 $subclass->anaccessor('fnord');
-is $subclass->anaccessor, 'wibble';
-is $subclass->anotherone, 'flibble';
+is($subclass->anaccessor, 'fnord');
+is($subclass->anotherone, 'flibble');
 $subclass->anotherone('fnord');
-is $subclass->anotherone, 'flibble';
+is($subclass->anotherone, 'flibble');