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