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