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

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