package MooseX::Emulate::Class::Accessor::Fast;
use Moose::Role;
+use Class::MOP ();
+use Scalar::Util ();
-our $VERSION = '0.00200';
+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
package MyClass;
- Use Moose;
+ use Moose;
with '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
=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 $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 $class = shift;
- my %args;
- if (scalar @_ == 1 && defined $_[0] && ref($_[0]) eq 'HASH') {
- %args = %{$_[0]};
- } else {
- %args = @_;
- }
- my $self = $class->$orig(@_);
+ my $self = shift;
+ my %args = %{ $_[0] };
+ $self->$orig(\%args);
my @extra = grep { !exists($self->{$_}) } keys %args;
@{$self}{@extra} = @args{@extra};
return $self;
=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']
+ );
+ }
}
}
=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");
+ }
}
}
=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");
+ }
}
}
=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');
=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
=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 ? [@_] : @_);
}
=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
L<Moose>, L<Moose::Meta::Attribute>, L<Class::Accessor>, L<Class::Accessor::Fast>,
L<Class::MOP::Attribute>, L<MooseX::Adopt::Class::Accessor::Fast>
-=head1 AUTHOR
+=head1 AUTHORS
+
+Guillermo Roditi (groditi) E<lt>groditi@cpan.orgE<gt>
+
+With contributions from:
+
+=over 4
+
+=item Tomas Doran (t0m) E<lt>bobtfish@bobtfish.netE<gt>
+
+=item Florian Ragwitz (rafl) E<lt>rafl@debian.orgE<gt>
-Guillermo Roditi (groditi) <groditi@cpan.org>
+=back
=head1 LICENSE
projects / gitmo/MooseX-Emulate-Class-Accessor-Fast.git / blobdiff