[catagits/Gitalist.git] / local-lib5 / lib / perl5 / MooseX / Emulate / Class / Accessor / Fast.pm

package MooseX::Emulate::Class::Accessor::Fast;

use Moose::Role;
use Class::MOP ();
use Scalar::Util ();

use MooseX::Emulate::Class::Accessor::Fast::Meta::Accessor ();

our $VERSION = '0.00903';

=head1 NAME

MooseX::Emulate::Class::Accessor::Fast - Emulate Class::Accessor::Fast behavior using Moose attributes

=head1 SYNOPSYS

    package MyClass;
    use Moose;

    with 'MooseX::Emulate::Class::Accessor::Fast';


    #fields with readers and writers
    __PACKAGE__->mk_accessors(qw/field1 field2/);
    #fields with readers only
    __PACKAGE__->mk_ro_accessors(qw/field3 field4/);
    #fields with writers only
    __PACKAGE__->mk_wo_accessors(qw/field5 field6/);


=head1 DESCRIPTION

This module attempts to emulate the behavior of L<Class::Accessor::Fast> as
accurately as possible using the Moose attribute system. The public API of
C<Class::Accessor::Fast> is wholly supported, but the private methods are not.
If you are only using the public methods (as you should) migration should be a
matter of switching your C<use base> line to a C<with> line.

While I have attempted to emulate the behavior of Class::Accessor::Fast as closely
as possible bugs may still be lurking in edge-cases.

=head1 BEHAVIOR

Simple documentation is provided here for your convenience, but for more thorough
documentation please see L<Class::Accessor::Fast> and L<Class::Accessor>.

=head2 A note about introspection

Please note that, at this time, the C<is> flag attribute is not being set. To
determine the C<reader> and C<writer> methods using introspection in later versions
of L<Class::MOP> ( > 0.38) please use the C<get_read_method> and C<get_write_method>
methods in L<Class::MOP::Attribute>. Example

    # with Class::MOP <= 0.38
    my $attr = $self->meta->find_attribute_by_name($field_name);
    my $reader_method = $attr->reader || $attr->accessor;
    my $writer_method = $attr->writer || $attr->accessor;

    # with Class::MOP > 0.38
    my $attr = $self->meta->find_attribute_by_name($field_name);
    my $reader_method = $attr->get_read_method;
    my $writer_method = $attr->get_write_method;

=head1 METHODS

=head2 BUILD $self %args

Change the default Moose class building to emulate the behavior of C::A::F and
store arguments in the instance hashref.

=cut

my $locate_metaclass = sub {
  my $class = Scalar::Util::blessed($_[0]) || $_[0];
  return Class::MOP::get_metaclass_by_name($class)
    || Moose::Meta::Class->initialize($class);
};

sub BUILD { }

around 'BUILD' => sub {
  my $orig = shift;
  my $self = shift;
  my %args = %{ $_[0] };
  $self->$orig(\%args);
  my @extra = grep { !exists($self->{$_}) } keys %args;
  @{$self}{@extra} = @args{@extra};
  return $self;
};

=head2 mk_accessors @field_names

Create read-write accessors. An attribute named C<$field_name> will be created.
The name of the c<reader> and C<writer> methods will be determined by the return
value of C<accessor_name_for> and C<mutator_name_for>, which by default return the
name passed unchanged. If the accessor and mutator names are equal the C<accessor>
attribute will be passes to Moose, otherwise the C<reader> and C<writer> attributes
will be passed. Please see L<Class::MOP::Attribute> for more information.

=cut

sub mk_accessors {
  my $self = shift;
  my $meta = $locate_metaclass->($self);
  my $class = $meta->name;
  confess("You are trying to modify ${class}, which has been made immutable, this is ".
    "not supported. Try subclassing ${class}, rather than monkeypatching it")
    if $meta->is_immutable;

  for my $attr_name (@_){
    $meta->remove_attribute($attr_name)
      if $meta->find_attribute_by_name($attr_name);
    my $reader = $self->accessor_name_for($attr_name);
    my $writer = $self->mutator_name_for( $attr_name);

    #dont overwrite existing methods
    if($reader eq $writer){
      my %opts = ( $meta->has_method($reader) ? ( is => 'bare' ) : (accessor => $reader) );
      my $attr = $meta->find_attribute_by_name($attr_name) || $meta->add_attribute($attr_name, %opts,
        traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
      );
      if($attr_name eq $reader){
        my $alias = "_${attr_name}_accessor";
        next if $meta->has_method($alias);
        $meta->add_method($alias => $attr->get_read_method_ref);
      }
    } else {
      my @opts = ( $meta->has_method($writer) ? () : (writer => $writer) );
      push(@opts, (reader => $reader)) unless $meta->has_method($reader);
      my $attr = $meta->find_attribute_by_name($attr_name) || $meta->add_attribute($attr_name, @opts,
        traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
      );
    }
  }
}

=head2 mk_ro_accessors @field_names

Create read-only accessors.

=cut

sub mk_ro_accessors {
  my $self = shift;
  my $meta = $locate_metaclass->($self);
  my $class = $meta->name;
  confess("You are trying to modify ${class}, which has been made immutable, this is ".
    "not supported. Try subclassing ${class}, rather than monkeypatching it")
    if $meta->is_immutable;
  for my $attr_name (@_){
    $meta->remove_attribute($attr_name)
      if $meta->find_attribute_by_name($attr_name);
    my $reader = $self->accessor_name_for($attr_name);
    my @opts = ($meta->has_method($reader) ? (is => 'bare') : (reader => $reader) );
    my $attr = $meta->add_attribute($attr_name, @opts,
      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
    ) if scalar(@opts);
    if($reader eq $attr_name && $reader eq $self->mutator_name_for($attr_name)){
      $meta->add_method("_${attr_name}_accessor" => $attr->get_read_method_ref)
        unless $meta->has_method("_${attr_name}_accessor");
    }
  }
}

=head2 mk_ro_accessors @field_names

Create write-only accessors.

=cut

#this is retarded.. but we need it for compatibility or whatever.
sub mk_wo_accessors {
  my $self = shift;
  my $meta = $locate_metaclass->($self);
  my $class = $meta->name;
  confess("You are trying to modify ${class}, which has been made immutable, this is ".
    "not supported. Try subclassing ${class}, rather than monkeypatching it")
    if $meta->is_immutable;
  for my $attr_name (@_){
    $meta->remove_attribute($attr_name)
      if $meta->find_attribute_by_name($attr_name);
    my $writer = $self->mutator_name_for($attr_name);
    my @opts = ($meta->has_method($writer) ? () : (writer => $writer) );
    my $attr = $meta->add_attribute($attr_name, @opts,
      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute']
    ) if scalar(@opts);
    if($writer eq $attr_name && $writer eq $self->accessor_name_for($attr_name)){
      $meta->add_method("_${attr_name}_accessor" => $attr->get_write_method_ref)
        unless $meta->has_method("_${attr_name}_accessor");
    }
  }
}

=head2 follow_best_practices

Preface readers with 'get_' and writers with 'set_'.
See original L<Class::Accessor> documentation for more information.

=cut

sub follow_best_practice {
  my $self = shift;
  my $meta = $locate_metaclass->($self);

  $meta->remove_method('mutator_name_for');
  $meta->remove_method('accessor_name_for');
  $meta->add_method('mutator_name_for',  sub{ return "set_".$_[1] });
  $meta->add_method('accessor_name_for', sub{ return "get_".$_[1] });
}

=head2 mutator_name_for

=head2 accessor_name_for

See original L<Class::Accessor> documentation for more information.

=cut

sub mutator_name_for  { return $_[1] }
sub accessor_name_for { return $_[1] }

=head2 set

See original L<Class::Accessor> documentation for more information.

=cut

sub set {
  my $self = shift;
  my $k = shift;
  confess "Wrong number of arguments received" unless scalar @_;
  my $meta = $locate_metaclass->($self);

  confess "No such attribute  '$k'"
    unless ( my $attr = $meta->find_attribute_by_name($k) );
  my $writer = $attr->get_write_method;
  $self->$writer(@_ > 1 ? [@_] : @_);
}

=head2 get

See original L<Class::Accessor> documentation for more information.

=cut

sub get {
  my $self = shift;
  confess "Wrong number of arguments received" unless scalar @_;
  my $meta = $locate_metaclass->($self);
  my @values;

  for( @_ ){
    confess "No such attribute  '$_'"
      unless ( my $attr = $meta->find_attribute_by_name($_) );
    my $reader = $attr->get_read_method;
    @_ > 1 ? push(@values, $self->$reader) : return $self->$reader;
  }

  return @values;
}

sub make_accessor {
  my($class, $field) = @_;
  my $meta = $locate_metaclass->($class);
  my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field,
      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute'],
     is => 'bare',
  );
  my $reader = $attr->get_read_method_ref;
  my $writer = $attr->get_write_method_ref;
  return sub {
    my $self = shift;
    return $reader->($self) unless @_;
    return $writer->($self,(@_ > 1 ? [@_] : @_));
  }
}


sub make_ro_accessor {
  my($class, $field) = @_;
  my $meta = $locate_metaclass->($class);
  my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field,
      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute'],
     is => 'bare',
  );
  return $attr->get_read_method_ref;
}


sub make_wo_accessor {
  my($class, $field) = @_;
  my $meta = $locate_metaclass->($class);
  my $attr = $meta->find_attribute_by_name($field) || $meta->add_attribute($field,
      traits => ['MooseX::Emulate::Class::Accessor::Fast::Meta::Role::Attribute'],
      is => 'bare',
  );
  return $attr->get_write_method_ref;
}

1;

=head2 meta

See L<Moose::Meta::Class>.

=cut

=head1 SEE ALSO

L<Moose>, L<Moose::Meta::Attribute>, L<Class::Accessor>, L<Class::Accessor::Fast>,
L<Class::MOP::Attribute>, L<MooseX::Adopt::Class::Accessor::Fast>

=head1 AUTHORS

Guillermo Roditi (groditi) E<lt>groditi@cpan.orgE<gt>

With contributions from:

=over 4

=item Tomas Doran (t0m) E<lt>bobtfish@bobtfish.netE<gt>

=item Florian Ragwitz (rafl) E<lt>rafl@debian.orgE<gt>

=back

=head1 LICENSE

You may distribute this code under the same terms as Perl itself.

=cut
Commit	Line	Data
3fea05b9	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.00903';
	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