X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=blobdiff_plain;f=lib%2FMooseX%2FEmulate%2FClass%2FAccessor%2FFast.pm;h=d2e4ca341b50b1afc528cefc09cdd2ba7863b09f;hb=72ed17b84d08a24f7c9c411db23d5b62da64ced0;hp=503f54f368e5974cc0993060461b2bcacdb86fa6;hpb=d82bc8be260465d7e6e4c050dd427ca58cd4f32a;p=gitmo%2FMooseX-Emulate-Class-Accessor-Fast.git

diff --git a/lib/MooseX/Emulate/Class/Accessor/Fast.pm b/lib/MooseX/Emulate/Class/Accessor/Fast.pm
index 503f54f..d2e4ca3 100644
--- a/lib/MooseX/Emulate/Class/Accessor/Fast.pm
+++ b/lib/MooseX/Emulate/Class/Accessor/Fast.pm
@@ -1,13 +1,16 @@
 package MooseX::Emulate::Class::Accessor::Fast;
 
 use Moose::Role;
+use Class::MOP ();
+use Scalar::Util ();
 
-our $VERSION = '0.00300';
+use MooseX::Emulate::Class::Accessor::Fast::Meta::Accessor ();
+
+our $VERSION = '0.00901';
 
 =head1 NAME
 
-MooseX::Emulate::Class::Accessor::Fast -
-  Emulate Class::Accessor::Fast behavior using Moose attributes
+MooseX::Emulate::Class::Accessor::Fast - Emulate Class::Accessor::Fast behavior using Moose attributes
 
 =head1 SYNOPSYS
 
@@ -20,9 +23,9 @@ MooseX::Emulate::Class::Accessor::Fast -
     #fields with readers and writers
     __PACKAGE__->mk_accessors(qw/field1 field2/);
     #fields with readers only
-    __PACKAGE__->mk_accessors(qw/field3 field4/);
+    __PACKAGE__->mk_ro_accessors(qw/field3 field4/);
     #fields with writers only
-    __PACKAGE__->mk_accessors(qw/field5 field6/);
+    __PACKAGE__->mk_wo_accessors(qw/field5 field6/);
 
 
 =head1 DESCRIPTION
@@ -67,18 +70,23 @@ store arguments in the instance hashref.
 
 =cut
 
-sub BUILD {
+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 { }
+
+around 'BUILD' => sub {
+  my $orig = shift;
   my $self = shift;
-  my %args;
-  if (scalar @_ == 1 && defined $_[0] && ref($_[0]) eq 'HASH') {
-    %args = %{$_[0]};
-  } elsif( scalar(@_) ) {
-    %args = @_;
-  }
+  my %args = %{ $_[0] };
+  $self->$orig(\%args);
   my @extra = grep { !exists($self->{$_}) } keys %args;
   @{$self}{@extra} = @args{@extra};
   return $self;
-}
+};
 
 =head2 mk_accessors @field_names
 
@@ -91,23 +99,38 @@ will be passed. Please see L<Class::MOP::Attribute> for more information.
 
 =cut
 
-sub mk_accessors{
+sub mk_accessors {
   my $self = shift;
-  my $meta = $self->meta;
+  my $meta = $locate_metaclass->($self);
+  my $class = $meta->name;
+  confess("You are trying to modify ${class}, which has been made immutable, this is ".
+    "not supported. Try subclassing ${class}, rather than monkeypatching it")
+    if $meta->is_immutable;
+
   for my $attr_name (@_){
+    $meta->remove_attribute($attr_name)
+      if $meta->find_attribute_by_name($attr_name);
     my $reader = $self->accessor_name_for($attr_name);
     my $writer = $self->mutator_name_for( $attr_name);
+
     #dont overwrite existing methods
-    my @opts = $reader eq $writer ?
-      ( $self->can($reader) ? () : (accessor => $reader) ) :
-        (
-         ( $self->can($reader) ? () : (reader => $reader) ),
-         ( $self->can($writer) ? () : (writer => $writer) ),
-        );
-    $meta->add_attribute($attr_name, @opts);
-
-    $meta->add_method("_${attr_name}_accessor", $self->can($reader) )
-      if($reader eq $attr_name && !$self->can("_${attr_name}_accessor") );
+    if($reader eq $writer){
+      my %opts = ( $meta->has_method($reader) ? ( is => 'bare' ) : (accessor => $reader) );
+      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);
+        $meta->add_method($alias => $attr->get_read_method_ref);
+      }
+    } else {
+      my @opts = ( $meta->has_method($writer) ? () : (writer => $writer) );
+      push(@opts, (reader => $reader)) unless $meta->has_method($reader);
+      my $attr = $meta->find_attribute_by_name($attr_name) || $meta->add_attribute($attr_name, @opts,
+        traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
+      );
+    }
   }
 }
 
@@ -117,15 +140,25 @@ Create read-only accessors.
 
 =cut
 
-sub mk_ro_accessors{
+sub mk_ro_accessors {
   my $self = shift;
-  my $meta = $self->meta;
+  my $meta = $locate_metaclass->($self);
+  my $class = $meta->name;
+  confess("You are trying to modify ${class}, which has been made immutable, this is ".
+    "not supported. Try subclassing ${class}, rather than monkeypatching it")
+    if $meta->is_immutable;
   for my $attr_name (@_){
+    $meta->remove_attribute($attr_name)
+      if $meta->find_attribute_by_name($attr_name);
     my $reader = $self->accessor_name_for($attr_name);
-    $meta->add_attribute($attr_name,
-                         $self->can($reader) ? () : (reader => $reader) );
-    $meta->add_method("_${attr_name}_accessor", $meta->find_method_by_name($reader))
-      if($reader eq $attr_name && !$self->can("_${attr_name}_accessor") );
+    my @opts = ($meta->has_method($reader) ? (is => 'bare') : (reader => $reader) );
+    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");
+    }
   }
 }
 
@@ -136,14 +169,25 @@ Create write-only accessors.
 =cut
 
 #this is retarded.. but we need it for compatibility or whatever.
-sub mk_wo_accessors{
+sub mk_wo_accessors {
   my $self = shift;
-  my $meta = $self->meta;
+  my $meta = $locate_metaclass->($self);
+  my $class = $meta->name;
+  confess("You are trying to modify ${class}, which has been made immutable, this is ".
+    "not supported. Try subclassing ${class}, rather than monkeypatching it")
+    if $meta->is_immutable;
   for my $attr_name (@_){
+    $meta->remove_attribute($attr_name)
+      if $meta->find_attribute_by_name($attr_name);
     my $writer = $self->mutator_name_for($attr_name);
-    $meta->add_attribute($attr_name, $self->can($writer) ? () : (writer => $writer) );
-    $meta->add_method("_${attr_name}_accessor", $meta->find_method_by_name($writer))
-      if($writer eq $attr_name && !$self->can("_${attr_name}_accessor") );
+    my @opts = ($meta->has_method($writer) ? () : (writer => $writer) );
+    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");
+    }
   }
 }
 
@@ -154,9 +198,9 @@ See original L<Class::Accessor> documentation for more information.
 
 =cut
 
-sub follow_best_practice{
+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');
@@ -172,8 +216,8 @@ See original L<Class::Accessor> documentation for more information.
 
 =cut
 
-sub mutator_name_for{  return $_[1] }
-sub accessor_name_for{ return $_[1] }
+sub mutator_name_for  { return $_[1] }
+sub accessor_name_for { return $_[1] }
 
 =head2 set
 
@@ -181,15 +225,15 @@ See original L<Class::Accessor> documentation for more information.
 
 =cut
 
-sub set{
+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 ? [@_] : @_);
 }
 
@@ -199,22 +243,60 @@ See original L<Class::Accessor> documentation for more information.
 
 =cut
 
-sub get{
+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;
   }
 
   return @values;
 }
 
+sub make_accessor {
+  my($class, $field) = @_;
+  my $meta = $locate_metaclass->($class);
+  my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field,
+      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute'],
+     is => 'bare',
+  );
+  my $reader = $attr->get_read_method_ref;
+  my $writer = $attr->get_write_method_ref;
+  return sub {
+    my $self = shift;
+    return $reader->($self) unless @_;
+    return $writer->($self,(@_ > 1 ? [@_] : @_));
+  }
+}
+
+
+sub make_ro_accessor {
+  my($class, $field) = @_;
+  my $meta = $locate_metaclass->($class);
+  my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field,
+      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute'],
+     is => 'bare',
+  );
+  return $attr->get_read_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,
+      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute'],
+      is => 'bare',
+  );
+  return $attr->get_write_method_ref;
+}
+
 1;
 
 =head2 meta
@@ -236,7 +318,9 @@ With contributions from:
 
 =over 4
 
-=item Tomas Doran E<lt>bobtfish@bobtfish.netE<gt>
+=item Tomas Doran (t0m) E<lt>bobtfish@bobtfish.netE<gt>
+
+=item Florian Ragwitz (rafl) E<lt>rafl@debian.orgE<gt>
 
 =back