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

   1 package MooseX::Emulate::Class::Accessor::Fast;
   2
   3 use Moose::Role;
   4
   5 our $VERSION = '0.00100';
   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 mk_accessors @field_names
  64
  65 Create read-write accessors. An attribute named C<$field_name> will be created.
  66 The name of the c<reader> and C<writer> methods will be determined by the return
  67 value of C<accessor_name_for> and C<mutator_name_for>, which by default return the
  68 name passed unchanged. If the accessor and mutator names are equal the C<accessor>
  69 attribute will be passes to Moose, otherwise the C<reader> and C<writer> attributes
  70 will be passed. Please see L<Class::MOP::Attribute> for more information.
  71
  72 =cut
  73
  74 sub mk_accessors{
  75   my $self = shift;
  76   my $meta = $self->meta;
  77   for my $attr_name (@_){
  78     my $reader = $self->accessor_name_for($attr_name);
  79     my $writer = $self->mutator_name_for( $attr_name);
  80     #dont overwrite existing methods
  81     my @opts = $reader eq $writer ?
  82       ( $self->can($reader) ? () : (accessor => $reader) ) :
  83         (
  84          ( $self->can($reader) ? () : (reader => $reader) ),
  85          ( $self->can($writer) ? () : (writer => $writer) ),
  86         );
  87     $meta->add_attribute($attr_name, @opts);
  88
  89     $meta->add_method("_${attr_name}_accessor", $self->can($reader) )
  90       if($reader eq $attr_name && !$self->can("_${attr_name}_accessor") );
  91   }
  92 }
  93
  94 =head2 mk_ro_accessors @field_names
  95
  96 Create read-only accessors.
  97
  98 =cut
  99
 100 sub mk_ro_accessors{
 101   my $self = shift;
 102   my $meta = $self->meta;
 103   for my $attr_name (@_){
 104     my $reader = $self->accessor_name_for($attr_name);
 105     $meta->add_attribute($attr_name,
 106                          $self->can($reader) ? () : (reader => $reader) );
 107     $meta->add_method("_${attr_name}_accessor", $meta->find_method_by_name($reader))
 108       if($reader eq $attr_name && !$self->can("_${attr_name}_accessor") );
 109   }
 110 }
 111
 112 =head2 mk_ro_accessors @field_names
 113
 114 Create write-only accessors.
 115
 116 =cut
 117
 118 #this is retarded.. but we need it for compatibility or whatever.
 119 sub mk_wo_accessors{
 120   my $self = shift;
 121   my $meta = $self->meta;
 122   for my $attr_name (@_){
 123     my $writer = $self->mutator_name_for($attr_name);
 124     $meta->add_attribute($attr_name, $self->can($writer) ? () : (writer => $writer) );
 125     $meta->add_method("_${attr_name}_accessor", $meta->find_method_by_name($writer))
 126       if($writer eq $attr_name && !$self->can("_${attr_name}_accessor") );
 127   }
 128 }
 129
 130 =head2 follow_best_practices
 131
 132 Preface readers with 'get_' and writers with 'set_'.
 133 See original L<Class::Accessor> documentation for more information.
 134
 135 =cut
 136
 137 sub follow_best_practice{
 138   my $self = shift;
 139   my $meta = $self->meta;
 140
 141   $meta->remove_method('mutator_name_for');
 142   $meta->remove_method('accessor_name_for');
 143   $meta->add_method('mutator_name_for',  sub{ return "set_".$_[1] });
 144   $meta->add_method('accessor_name_for', sub{ return "get_".$_[1] });
 145 }
 146
 147 =head2 mutator_name_for
 148
 149 =head2 accessor_name_for
 150
 151 See original L<Class::Accessor> documentation for more information.
 152
 153 =cut
 154
 155 sub mutator_name_for{  return $_[1] }
 156 sub accessor_name_for{ return $_[1] }
 157
 158 =head2 set
 159
 160 See original L<Class::Accessor> documentation for more information.
 161
 162 =cut
 163
 164 sub set{
 165   my $self = shift;
 166   my $k = shift;
 167   confess "Wrong number of arguments received" unless scalar @_;
 168
 169   #my $writer = $self->mutator_name_for( $k );
 170   confess "No such attribute  '$k'"
 171     unless ( my $attr = $self->meta->find_attribute_by_name($k) );
 172   my $writer = $attr->writer || $attr->accessor;
 173   $self->$writer(@_ > 1 ? [@_] : @_);
 174 }
 175
 176 =head2 get
 177
 178 See original L<Class::Accessor> documentation for more information.
 179
 180 =cut
 181
 182 sub get{
 183   my $self = shift;
 184   confess "Wrong number of arguments received" unless scalar @_;
 185
 186   my @values;
 187   #while( my $attr = $self->meta->find_attribute_by_name( shift(@_) ){
 188   for( @_ ){
 189     confess "No such attribute  '$_'"
 190       unless ( my $attr = $self->meta->find_attribute_by_name($_) );
 191     my $reader = $attr->reader || $attr->accessor;
 192     @_ > 1 ? push(@values, $self->$reader) : return $self->$reader;
 193   }
 194
 195   return @values;
 196 }
 197
 198 1;
 199
 200 =head2 meta
 201
 202 See L<Moose::Meta::Class>.
 203
 204 =cut
 205
 206 =head1 SEE ALSO
 207
 208 L<Moose>, L<Moose::Meta::Attribute>, L<Class::Accessor>, L<Class::Accessor::Fast>,
 209 L<Class::MOP::Attribute>, L<MooseX::Adopt::Class::Accessor::Fast>
 210
 211 =head1 AUTHOR
 212
 213 Guillermo Roditi (groditi) <groditi@cpan.org>
 214
 215 =head1 LICENSE
 216
 217 You may distribute this code under the same terms as Perl itself.
 218
 219 =cut