lib/MooseX/Emulate/Class/Accessor/Fast.pm

   1 package MooseX::Emulate::Class::Accessor::Fast;
   2
   3 use Moose::Role;
   4 use Class::MOP ();
   5 use Scalar::Util ();
   6
   7 use MooseX::Emulate::Class::Accessor::Fast::Meta::Accessor ();
   8
   9 our $VERSION = '0.00800';
  10
  11 =head1 NAME
  12
  13 MooseX::Emulate::Class::Accessor::Fast -
  14   Emulate Class::Accessor::Fast behavior using Moose attributes
  15
  16 =head1 SYNOPSYS
  17
  18     package MyClass;
  19     use Moose;
  20
  21     with 'MooseX::Emulate::Class::Accessor::Fast';
  22
  23
  24     #fields with readers and writers
  25     __PACKAGE__->mk_accessors(qw/field1 field2/);
  26     #fields with readers only
  27     __PACKAGE__->mk_accessors(qw/field3 field4/);
  28     #fields with writers only
  29     __PACKAGE__->mk_accessors(qw/field5 field6/);
  30
  31
  32 =head1 DESCRIPTION
  33
  34 This module attempts to emulate the behavior of L<Class::Accessor::Fast> as
  35 accurately as possible using the Moose attribute system. The public API of
  36 C<Class::Accessor::Fast> is wholly supported, but the private methods are not.
  37 If you are only using the public methods (as you should) migration should be a
  38 matter of switching your C<use base> line to a C<with> line.
  39
  40 While I have attempted to emulate the behavior of Class::Accessor::Fast as closely
  41 as possible bugs may still be lurking in edge-cases.
  42
  43 =head1 BEHAVIOR
  44
  45 Simple documentation is provided here for your convenience, but for more thorough
  46 documentation please see L<Class::Accessor::Fast> and L<Class::Accessor>.
  47
  48 =head2 A note about introspection
  49
  50 Please note that, at this time, the C<is> flag attribute is not being set. To
  51 determine the C<reader> and C<writer> methods using introspection in later versions
  52 of L<Class::MOP> ( > 0.38) please use the C<get_read_method> and C<get_write_method>
  53 methods in L<Class::MOP::Attribute>. Example
  54
  55     # with Class::MOP <= 0.38
  56     my $attr = $self->meta->find_attribute_by_name($field_name);
  57     my $reader_method = $attr->reader || $attr->accessor;
  58     my $writer_method = $attr->writer || $attr->accessor;
  59
  60     # with Class::MOP > 0.38
  61     my $attr = $self->meta->find_attribute_by_name($field_name);
  62     my $reader_method = $attr->get_read_method;
  63     my $writer_method = $attr->get_write_method;
  64
  65 =head1 METHODS
  66
  67 =head2 BUILD $self %args
  68
  69 Change the default Moose class building to emulate the behavior of C::A::F and
  70 store arguments in the instance hashref.
  71
  72 =cut
  73
  74 my $locate_metaclass = sub {
  75   my $class = Scalar::Util::blessed($_[0]) || $_[0];
  76   return Class::MOP::get_metaclass_by_name($class)
  77     || Moose::Meta::Class->initialize($class);
  78 };
  79
  80 sub BUILD {
  81   my $self = shift;
  82   my %args;
  83   if (scalar @_ == 1 && defined $_[0] && ref($_[0]) eq 'HASH') {
  84     %args = %{$_[0]};
  85   } elsif( scalar(@_) ) {
  86     %args = @_;
  87   }
  88   my @extra = grep { !exists($self->{$_}) } keys %args;
  89   @{$self}{@extra} = @args{@extra};
  90   return $self;
  91 }
  92
  93 =head2 mk_accessors @field_names
  94
  95 Create read-write accessors. An attribute named C<$field_name> will be created.
  96 The name of the c<reader> and C<writer> methods will be determined by the return
  97 value of C<accessor_name_for> and C<mutator_name_for>, which by default return the
  98 name passed unchanged. If the accessor and mutator names are equal the C<accessor>
  99 attribute will be passes to Moose, otherwise the C<reader> and C<writer> attributes
 100 will be passed. Please see L<Class::MOP::Attribute> for more information.
 101
 102 =cut
 103
 104 sub mk_accessors {
 105   my $self = shift;
 106   my $meta = $locate_metaclass->($self);
 107   my $class = $meta->name;
 108   confess("You are trying to modify ${class}, which has been made immutable, this is ".
 109     "not supported. Try subclassing ${class}, rather than monkeypatching it")
 110     if $meta->is_immutable;
 111
 112   for my $attr_name (@_){
 113     $meta->remove_attribute($attr_name)
 114       if $meta->find_attribute_by_name($attr_name);
 115     my $reader = $self->accessor_name_for($attr_name);
 116     my $writer = $self->mutator_name_for( $attr_name);
 117
 118     #dont overwrite existing methods
 119     if($reader eq $writer){
 120       my %opts = ( $meta->has_method($reader) ? () : (accessor => $reader) );
 121       my $attr = $meta->find_attribute_by_name($attr_name) || $meta->add_attribute($attr_name, %opts,
 122         traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
 123       );
 124       if($attr_name eq $reader){
 125         my $alias = "_${attr_name}_accessor";
 126         next if $meta->has_method($alias);
 127         $meta->add_method($alias => $attr->get_read_method_ref);
 128       }
 129     } else {
 130       my @opts = ( $meta->has_method($writer) ? () : (writer => $writer) );
 131       push(@opts, (reader => $reader)) unless $meta->has_method($reader);
 132       my $attr = $meta->find_attribute_by_name($attr_name) || $meta->add_attribute($attr_name, @opts,
 133         traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
 134       );
 135     }
 136   }
 137 }
 138
 139 =head2 mk_ro_accessors @field_names
 140
 141 Create read-only accessors.
 142
 143 =cut
 144
 145 sub mk_ro_accessors {
 146   my $self = shift;
 147   my $meta = $locate_metaclass->($self);
 148   my $class = $meta->name;
 149   confess("You are trying to modify ${class}, which has been made immutable, this is ".
 150     "not supported. Try subclassing ${class}, rather than monkeypatching it")
 151     if $meta->is_immutable;
 152   for my $attr_name (@_){
 153     $meta->remove_attribute($attr_name)
 154       if $meta->find_attribute_by_name($attr_name);
 155     my $reader = $self->accessor_name_for($attr_name);
 156     my @opts = ($meta->has_method($reader) ? () : (reader => $reader) );
 157     my $attr = $meta->add_attribute($attr_name, @opts,
 158       traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
 159     ) if scalar(@opts);
 160     if($reader eq $attr_name && $reader eq $self->mutator_name_for($attr_name)){
 161       $meta->add_method("_${attr_name}_accessor" => $attr->get_read_method_ref)
 162         unless $meta->has_method("_${attr_name}_accessor");
 163     }
 164   }
 165 }
 166
 167 =head2 mk_ro_accessors @field_names
 168
 169 Create write-only accessors.
 170
 171 =cut
 172
 173 #this is retarded.. but we need it for compatibility or whatever.
 174 sub mk_wo_accessors {
 175   my $self = shift;
 176   my $meta = $locate_metaclass->($self);
 177   my $class = $meta->name;
 178   confess("You are trying to modify ${class}, which has been made immutable, this is ".
 179     "not supported. Try subclassing ${class}, rather than monkeypatching it")
 180     if $meta->is_immutable;
 181   for my $attr_name (@_){
 182     $meta->remove_attribute($attr_name)
 183       if $meta->find_attribute_by_name($attr_name);
 184     my $writer = $self->mutator_name_for($attr_name);
 185     my @opts = ($meta->has_method($writer) ? () : (writer => $writer) );
 186     my $attr = $meta->add_attribute($attr_name, @opts,
 187       traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
 188     ) if scalar(@opts);
 189     if($writer eq $attr_name && $writer eq $self->accessor_name_for($attr_name)){
 190       $meta->add_method("_${attr_name}_accessor" => $attr->get_write_method_ref)
 191         unless $meta->has_method("_${attr_name}_accessor");
 192     }
 193   }
 194 }
 195
 196 =head2 follow_best_practices
 197
 198 Preface readers with 'get_' and writers with 'set_'.
 199 See original L<Class::Accessor> documentation for more information.
 200
 201 =cut
 202
 203 sub follow_best_practice {
 204   my $self = shift;
 205   my $meta = $locate_metaclass->($self);
 206
 207   $meta->remove_method('mutator_name_for');
 208   $meta->remove_method('accessor_name_for');
 209   $meta->add_method('mutator_name_for',  sub{ return "set_".$_[1] });
 210   $meta->add_method('accessor_name_for', sub{ return "get_".$_[1] });
 211 }
 212
 213 =head2 mutator_name_for
 214
 215 =head2 accessor_name_for
 216
 217 See original L<Class::Accessor> documentation for more information.
 218
 219 =cut
 220
 221 sub mutator_name_for  { return $_[1] }
 222 sub accessor_name_for { return $_[1] }
 223
 224 =head2 set
 225
 226 See original L<Class::Accessor> documentation for more information.
 227
 228 =cut
 229
 230 sub set {
 231   my $self = shift;
 232   my $k = shift;
 233   confess "Wrong number of arguments received" unless scalar @_;
 234   my $meta = $locate_metaclass->($self);
 235
 236   confess "No such attribute  '$k'"
 237     unless ( my $attr = $meta->find_attribute_by_name($k) );
 238   my $writer = $attr->get_write_method;
 239   $self->$writer(@_ > 1 ? [@_] : @_);
 240 }
 241
 242 =head2 get
 243
 244 See original L<Class::Accessor> documentation for more information.
 245
 246 =cut
 247
 248 sub get {
 249   my $self = shift;
 250   confess "Wrong number of arguments received" unless scalar @_;
 251   my $meta = $locate_metaclass->($self);
 252   my @values;
 253
 254   for( @_ ){
 255     confess "No such attribute  '$_'"
 256       unless ( my $attr = $meta->find_attribute_by_name($_) );
 257     my $reader = $attr->get_read_method;
 258     @_ > 1 ? push(@values, $self->$reader) : return $self->$reader;
 259   }
 260
 261   return @values;
 262 }
 263
 264 sub make_accessor {
 265   my($class, $field) = @_;
 266   my $meta = $locate_metaclass->($class);
 267   my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field,
 268       traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
 269   );
 270   my $reader = $attr->get_read_method_ref;
 271   my $writer = $attr->get_write_method_ref;
 272   return sub {
 273     my $self = shift;
 274     return $reader->($self) unless @_;
 275     return $writer->($self,(@_ > 1 ? [@_] : @_));
 276   }
 277 }
 278
 279
 280 sub make_ro_accessor {
 281   my($class, $field) = @_;
 282   my $meta = $locate_metaclass->($class);
 283   my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field,
 284       traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
 285   );
 286   return $attr->get_read_method_ref;
 287 }
 288
 289
 290 sub make_wo_accessor {
 291   my($class, $field) = @_;
 292   my $meta = $locate_metaclass->($class);
 293   my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field,
 294       traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
 295   );
 296   return $attr->get_write_method_ref;
 297 }
 298
 299 1;
 300
 301 =head2 meta
 302
 303 See L<Moose::Meta::Class>.
 304
 305 =cut
 306
 307 =head1 SEE ALSO
 308
 309 L<Moose>, L<Moose::Meta::Attribute>, L<Class::Accessor>, L<Class::Accessor::Fast>,
 310 L<Class::MOP::Attribute>, L<MooseX::Adopt::Class::Accessor::Fast>
 311
 312 =head1 AUTHORS
 313
 314 Guillermo Roditi (groditi) E<lt>groditi@cpan.orgE<gt>
 315
 316 With contributions from:
 317
 318 =over 4
 319
 320 =item Tomas Doran (t0m) E<lt>bobtfish@bobtfish.netE<gt>
 321
 322 =item Florian Ragwitz (rafl) E<lt>rafl@debian.orgE<gt>
 323
 324 =back
 325
 326 =head1 LICENSE
 327
 328 You may distribute this code under the same terms as Perl itself.
 329
 330 =cut