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

   1 package MooseX::Emulate::Class::Accessor::Fast;
   2
   3 use Moose;
   4
   5 our $VERSION = 0.0001;
   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
  16     use base 'MooseX::Emulate::Class::Accessor::Fast';
  17     #or
  18     use Moose;
  19     extends 'MooseX::Emulate::Class::Accessor::Fast';
  20
  21     #fields with readers and writers
  22     __PACKAGE__->mk_accessors(qw/field1 field2/);
  23     #fields with readers only
  24     __PACKAGE__->mk_accessors(qw/field3 field4/);
  25     #fields with writers only
  26     __PACKAGE__->mk_accessors(qw/field5 field6/);
  27
  28
  29 =head1 DESCRIPTION
  30
  31 This module attempts to emulate the behavior of L<Class::Accessor::Fast> as
  32 accurately as possible using the Moose attribute system. The public API of
  33 C<Class::Accessor::Fast> is wholly supported, but the private methods are not.
  34 If you are only using the public methods (as you should) migration should be a
  35 matter of switching your C<use base> line.
  36
  37 While I have attempted to emulate the behavior of Class::Accessor::Fast as closely
  38 as possible bugs may still be lurking in edge-cases.
  39
  40 =head1 BEHAVIOR
  41
  42 Simple documentation is provided here for your convenience, but for more thorough
  43 documentation please see L<Class::Accessor::Fast> and L<Class::Accessor>.
  44
  45 =head2 A note about introspection
  46
  47 Please note that, at this time, the C<is> flag attribute is not being set. To
  48 determine the C<reader> and C<writer> methods using introspection in later versions
  49 of L<Class::MOP> ( > 0.38) please use the C<get_read_method> and C<get_write_method>
  50 methods in L<Class::MOP::Attribute>. Example
  51
  52     # with Class::MOP <= 0.38
  53     my $attr = $self->meta->find_attribute_by_name($field_name);
  54     my $reader_method = $attr->reader || $attr->accessor;
  55     my $writer_method = $attr->writer || $attr->accessor;
  56
  57     # with Class::MOP > 0.38
  58     my $attr = $self->meta->find_attribute_by_name($field_name);
  59     my $reader_method = $attr->get_read_method;
  60     my $writer_method = $attr->get_write_method;
  61
  62 =head1 METHODS
  63
  64 =head2 mk_accessors @field_names
  65
  66 Create read-write accessors. An attribute named C<$field_name> will be created.
  67 The name of the c<reader> and C<writer> methods will be determined by the return
  68 value of C<accessor_name_for> and C<mutator_name_for>, which by default return the
  69 name passed unchanged. If the accessor and mutator names are equal the C<accessor>
  70 attribute will be passes to Moose, otherwise the C<reader> and C<writer> attributes
  71 will be passed. Please see L<Class::MOP::Attribute> for more information.
  72
  73 =cut
  74
  75 sub mk_accessors{
  76   my $self = shift;
  77   my $meta = $self->meta;
  78   for my $attr_name (@_){
  79     my $reader = $self->accessor_name_for($attr_name);
  80     my $writer = $self->mutator_name_for( $attr_name);
  81     #dont overwrite existing methods
  82     my @opts = $reader eq $writer ?
  83       ( $self->can($reader) ? () : (accessor => $reader) ) :
  84         (
  85          ( $self->can($reader) ? () : (reader => $reader) ),
  86          ( $self->can($writer) ? () : (writer => $writer) ),
  87         );
  88     $meta->add_attribute($attr_name, @opts);
  89
  90     $meta->add_method("_${attr_name}_accessor", $self->can($reader) )
  91       if($reader eq $attr_name && !$self->can("_${attr_name}_accessor") );
  92   }
  93 }
  94
  95 =head2 mk_ro_accessors @field_names
  96
  97 Create read-only accessors.
  98
  99 =cut
 100
 101 sub mk_ro_accessors{
 102   my $self = shift;
 103   my $meta = $self->meta;
 104   for my $attr_name (@_){
 105     my $reader = $self->accessor_name_for($attr_name);
 106     $meta->add_attribute($attr_name,
 107                          $self->can($reader) ? () : (reader => $reader) );
 108     $meta->add_method("_${attr_name}_accessor", $meta->find_method_by_name($reader))
 109       if($reader eq $attr_name && !$self->can("_${attr_name}_accessor") );
 110   }
 111 }
 112
 113 =head2 mk_ro_accessors @field_names
 114
 115 Create write-only accessors.
 116
 117 =cut
 118
 119 #this is retarded.. but we need it for compatibility or whatever.
 120 sub mk_wo_accessors{
 121   my $self = shift;
 122   my $meta = $self->meta;
 123   for my $attr_name (@_){
 124     my $writer = $self->mutator_name_for($attr_name);
 125     $meta->add_attribute($attr_name, $self->can($writer) ? () : (writer => $writer) );
 126     $meta->add_method("_${attr_name}_accessor", $meta->find_method_by_name($writer))
 127       if($writer eq $attr_name && !$self->can("_${attr_name}_accessor") );
 128   }
 129 }
 130
 131 =head2 follow_best_practices
 132
 133 Preface readers with 'get_' and writers with 'set_'.
 134 See original L<Class::Accessor> documentation for more information.
 135
 136 =cut
 137
 138 sub follow_best_practice{
 139   my $self = shift;
 140   my $meta = $self->meta;
 141
 142   $meta->remove_method('mutator_name_for');
 143   $meta->remove_method('accessor_name_for');
 144   $meta->add_method('mutator_name_for',  sub{ return "set_".$_[1] });
 145   $meta->add_method('accessor_name_for', sub{ return "get_".$_[1] });
 146 }
 147
 148 =head2 mutator_name_for
 149
 150 =head2 accessor_name_for
 151
 152 See original L<Class::Accessor> documentation for more information.
 153
 154 =cut
 155
 156 sub mutator_name_for{  return $_[1] }
 157 sub accessor_name_for{ return $_[1] }
 158
 159 =head2 set
 160
 161 See original L<Class::Accessor> documentation for more information.
 162
 163 =cut
 164
 165 sub set{
 166   my $self = shift;
 167   my $k = shift;
 168   confess "Wrong number of arguments received" unless scalar @_;
 169
 170   #my $writer = $self->mutator_name_for( $k );
 171   confess "No such attribute  '$k'"
 172     unless ( my $attr = $self->meta->find_attribute_by_name($k) );
 173   my $writer = $attr->writer || $attr->accessor;
 174   $self->$writer(@_ > 1 ? [@_] : @_);
 175 }
 176
 177 =head2 get
 178
 179 See original L<Class::Accessor> documentation for more information.
 180
 181 =cut
 182
 183 sub get{
 184   my $self = shift;
 185   confess "Wrong number of arguments received" unless scalar @_;
 186
 187   my @values;
 188   #while( my $attr = $self->meta->find_attribute_by_name( shift(@_) ){
 189   for( @_ ){
 190     confess "No such attribute  '$_'"
 191       unless ( my $attr = $self->meta->find_attribute_by_name($_) );
 192     my $reader = $attr->reader || $attr->accessor;
 193     @_ > 1 ? push(@values, $self->$reader) : return $self->$reader;
 194   }
 195
 196   return @values;
 197 }
 198
 199 1;
 200
 201 =head2 meta
 202
 203 See L<Moose::Meta::Class>.
 204
 205 =cut
 206
 207 =head1 SEE ALSO
 208
 209 L<Moose>, L<Moose::Meta::Attribute>, L<Class::Accessor>, L<Class::Accessor::Fast>,
 210 L<Class::MOP::Attribute>, L<MooseX::Adopt::Class::Accessor::Fast>
 211
 212 =head1 AUTHOR
 213
 214 Guillermo Roditi (groditi) <groditi@cpan.org>
 215
 216 =head1 LICENSE
 217
 218 You may distribute this code under the same terms as Perl itself.
 219
 220 =cut