use strict;
use warnings;
-our $VERSION = '0.04';
+our $VERSION = '0.05';
use base 'Class::MOP::Attribute';
default => sub { {} },
));
+sub accessor_metaclass { 'AttributesWithHistory::Method::Accessor' }
+
+AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub {
+ my ($self) = @_;
+ # and now add the history accessor
+ $self->associated_class->add_method(
+ $self->process_accessors('history_accessor' => $self->history_accessor())
+ ) if $self->has_history_accessor();
+});
+
+package # hide the package from PAUSE
+ AttributesWithHistory::Method::Accessor;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Method::Accessor';
+
# generate the methods
sub generate_history_accessor_method {
- my ($self, $attr_name) = @_;
+ my $attr_name = (shift)->associated_attribute->name;
eval qq{sub {
unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
}
sub generate_accessor_method {
- my ($self, $attr_name) = @_;
+ my $attr_name = (shift)->associated_attribute->name;
eval qq{sub {
if (scalar(\@_) == 2) {
unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
}
sub generate_writer_method {
- my ($self, $attr_name) = @_;
+ my $attr_name = (shift)->associated_attribute->name;
eval qq{sub {
unless (ref \$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}) \{
\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\} = [];
push \@\{\$_[0]->meta->get_attribute('$attr_name')->_history()->\{\$_[0]\}\} => \$_[1];
\$_[0]->{'$attr_name'} = \$_[1];
}};
-}
-
-AttributesWithHistory->meta->add_after_method_modifier('install_accessors' => sub {
- my ($self) = @_;
- # and now add the history accessor
- $self->associated_class->add_method(
- $self->process_accessors('history_accessor' => $self->history_accessor())
- ) if $self->has_history_accessor();
-});
+}
1;
use strict;
use warnings;
-our $VERSION = '0.01';
+our $VERSION = '0.02';
use Carp 'confess';
use Scalar::Util 'refaddr';
$_meta_instance->set_slot_value($instance, $self->name, $val);
}
+sub accessor_metaclass { 'InsideOutClass::Method::Accessor' }
+
+package # hide the package from PAUSE
+ InsideOutClass::Method::Accessor;
+
+use strict;
+use warnings;
+
+our $VERSION = '0.01';
+
+use Carp 'confess';
+use Scalar::Util 'refaddr';
+
+use base 'Class::MOP::Method::Accessor';
+
## Method generation helpers
sub generate_accessor_method {
- my $self = shift;
- my $meta_class = $self->associated_class;
- my $attr_name = $self->name;
+ my $attr = (shift)->associated_attribute;
+ my $meta_class = $attr->associated_class;
+ my $attr_name = $attr->name;
return sub {
my $meta_instance = $meta_class->get_meta_instance;
$meta_instance->set_slot_value($_[0], $attr_name, $_[1]) if scalar(@_) == 2;
}
sub generate_reader_method {
- my $self = shift;
- my $meta_class = $self->associated_class;
- my $attr_name = $self->name;
+ my $attr = (shift)->associated_attribute;
+ my $meta_class = $attr->associated_class;
+ my $attr_name = $attr->name;
return sub {
confess "Cannot assign a value to a read-only accessor" if @_ > 1;
$meta_class->get_meta_instance
}
sub generate_writer_method {
- my $self = shift;
- my $meta_class = $self->associated_class;
- my $attr_name = $self->name;
+ my $attr = (shift)->associated_attribute;
+ my $meta_class = $attr->associated_class;
+ my $attr_name = $attr->name;
return sub {
$meta_class->get_meta_instance
->set_slot_value($_[0], $attr_name, $_[1]);
}
sub generate_predicate_method {
- my $self = shift;
- my $meta_class = $self->associated_class;
- my $attr_name = $self->name;
+ my $attr = (shift)->associated_attribute;
+ my $meta_class = $attr->associated_class;
+ my $attr_name = $attr->name;
return sub {
defined $meta_class->get_meta_instance
->get_slot_value($_[0], $attr_name) ? 1 : 0;
use Carp 'confess';
-our $VERSION = '0.04';
+our $VERSION = '0.05';
use base 'Class::MOP::Attribute';
}
}
+sub accessor_metaclass { 'LazyClass::Method::Accessor' }
+
+package # hide the package from PAUSE
+ LazyClass::Method::Accessor;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+
+our $VERSION = '0.01';
+
+use base 'Class::MOP::Method::Accessor';
+
sub generate_accessor_method {
- my $attr = shift;
+ my $attr = (shift)->associated_attribute;
my $attr_name = $attr->name;
my $meta_instance = $attr->associated_class->get_meta_instance;
}
sub generate_reader_method {
- my $attr = shift;
+ my $attr = (shift)->associated_attribute;
my $attr_name = $attr->name;
my $meta_instance = $attr->associated_class->get_meta_instance;
};
}
-
-
package # hide the package from PAUSE
LazyClass::Instance;
Class::MOP::Object
- Class::MOP::Attribute::Accessor
+ Class::MOP::Method::Accessor
Class::MOP::Method::Wrapped
/;
use strict;
use warnings;
+use Class::MOP::Method::Accessor;
+
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype', 'weaken';
->get_slot_value($instance, $self->name);
}
-## Method generation helpers
-
-sub generate_accessor_method {
- my $attr = shift;
- return sub {
- $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
- $attr->get_value($_[0]);
- };
-}
-
-sub generate_accessor_method_inline {
- my $self = shift;
- my $attr_name = $self->name;
- my $meta_instance = $self->associated_class->instance_metaclass;
-
- my $code = eval 'sub {'
- . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]') . ' if scalar(@_) == 2; '
- . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'")
- . '}';
- confess "Could not generate inline accessor because : $@" if $@;
-
- return $code;
-}
-
-sub generate_reader_method {
- my $attr = shift;
- return sub {
- confess "Cannot assign a value to a read-only accessor" if @_ > 1;
- $attr->get_value($_[0]);
- };
-}
-
-sub generate_reader_method_inline {
- my $self = shift;
- my $attr_name = $self->name;
- my $meta_instance = $self->associated_class->instance_metaclass;
-
- my $code = eval 'sub {'
- . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
- . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'")
- . '}';
- confess "Could not generate inline accessor because : $@" if $@;
-
- return $code;
-}
-
-sub generate_writer_method {
- my $attr = shift;
- return sub {
- $attr->set_value($_[0], $_[1]);
- };
-}
-
-sub generate_writer_method_inline {
- my $self = shift;
- my $attr_name = $self->name;
- my $meta_instance = $self->associated_class->instance_metaclass;
-
- my $code = eval 'sub {'
- . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]')
- . '}';
- confess "Could not generate inline accessor because : $@" if $@;
-
- return $code;
-}
-
-sub generate_predicate_method {
- my $self = shift;
- my $attr_name = $self->name;
- return sub {
- defined Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
- ->get_meta_instance
- ->get_slot_value($_[0], $attr_name) ? 1 : 0;
- };
-}
-
-sub generate_clearer_method {
- my $self = shift;
- my $attr_name = $self->name;
- return sub {
- Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
- ->get_meta_instance
- ->deinitialize_slot($_[0], $attr_name);
- };
-}
-
-sub generate_predicate_method_inline {
- my $self = shift;
- my $attr_name = $self->name;
- my $meta_instance = $self->associated_class->instance_metaclass;
+## load em up ...
- my $code = eval 'sub {'
- . 'defined ' . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'") . ' ? 1 : 0'
- . '}';
- confess "Could not generate inline predicate because : $@" if $@;
-
- return $code;
-}
-
-sub generate_clearer_method_inline {
- my $self = shift;
- my $attr_name = $self->name;
- my $meta_instance = $self->associated_class->instance_metaclass;
-
- my $code = eval 'sub {'
- . $meta_instance->inline_deinitialize_slot('$_[0]', "'$attr_name'")
- . '}';
- confess "Could not generate inline clearer because : $@" if $@;
-
- return $code;
-}
+sub accessor_metaclass { 'Class::MOP::Method::Accessor' }
sub process_accessors {
my ($self, $type, $accessor, $generate_as_inline_methods) = @_;
(reftype($accessor) eq 'HASH')
|| confess "bad accessor/reader/writer/predicate/clearer format, must be a HASH ref";
my ($name, $method) = %{$accessor};
- return ($name, Class::MOP::Attribute::Accessor->wrap($method));
+ return ($name, $self->accessor_metaclass->wrap($method));
}
else {
- my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
- my $generator = $self->can('generate_' . $type . '_method' . ($inline_me ? '_inline' : ''));
- ($generator)
- || confess "There is no method generator for the type='$type'";
- if (my $method = $self->$generator($self->name)) {
- return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
- }
- confess "Could not create the '$type' method for " . $self->name . " because : $@";
+ my $inline_me = ($generate_as_inline_methods && $self->associated_class->instance_metaclass->is_inlinable);
+ my $method;
+ eval {
+ $method = $self->accessor_metaclass->new(
+ attribute => $self,
+ as_inline => $inline_me,
+ accessor_type => $type,
+ );
+ };
+ confess "Could not create the '$type' method for " . $self->name . " because : $@" if $@;
+ return ($accessor, $method);
}
}
}
my $method = $class->get_method($accessor);
$class->remove_method($accessor)
- if (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'));
+ if (blessed($method) && $method->isa('Class::MOP::Method::Accessor'));
};
sub remove_accessors {
}
-package Class::MOP::Attribute::Accessor;
-
-use strict;
-use warnings;
-
-use Class::MOP::Method;
-
-our $VERSION = '0.02';
-our $AUTHORITY = 'cpan:STEVAN';
-
-use base 'Class::MOP::Method';
-
1;
__END__
=over 4
+=item B<accessor_metaclass>
+
=item B<install_accessors>
This allows the attribute to generate and install code for it's own
(using the C<generate_*_method> methods listed below) or it will
use the custom method passed through the constructor.
-=over 4
-
-=item B<generate_accessor_method>
-
-=item B<generate_predicate_method>
-
-=item B<generate_clearer_method>
-
-=item B<generate_reader_method>
-
-=item B<generate_writer_method>
-
-=back
-
-=over 4
-
-=item B<generate_accessor_method_inline>
-
-=item B<generate_predicate_method_inline>
-
-=item B<generate_clearer_method_inline>
-
-=item B<generate_reader_method_inline>
-
-=item B<generate_writer_method_inline>
-
-=back
-
=item B<remove_accessors>
This allows the attribute to remove the method for it's own
use strict;
use warnings;
+use Class::MOP::Instance;
+use Class::MOP::Method::Wrapped;
+
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype', 'weaken';
use Sub::Name 'subname';
use base 'Class::MOP::Module';
-use Class::MOP::Instance;
-
# Self-introspection
sub meta { Class::MOP::Class->initialize(blessed($_[0]) || $_[0]) }
$code->package_name . '::' . $code->name;
}
-package Class::MOP::Method::Wrapped;
-
-use strict;
-use warnings;
-
-use Carp 'confess';
-use Scalar::Util 'reftype', 'blessed';
-use Sub::Name 'subname';
-
-our $VERSION = '0.02';
-our $AUTHORITY = 'cpan:STEVAN';
-
-use base 'Class::MOP::Method';
-
-# NOTE:
-# this ugly beast is the result of trying
-# to micro optimize this as much as possible
-# while not completely loosing maintainability.
-# At this point it's "fast enough", after all
-# you can't get something for nothing :)
-my $_build_wrapped_method = sub {
- my $modifier_table = shift;
- my ($before, $after, $around) = (
- $modifier_table->{before},
- $modifier_table->{after},
- $modifier_table->{around},
- );
- if (@$before && @$after) {
- $modifier_table->{cache} = sub {
- $_->(@_) for @{$before};
- my @rval;
- ((defined wantarray) ?
- ((wantarray) ?
- (@rval = $around->{cache}->(@_))
- :
- ($rval[0] = $around->{cache}->(@_)))
- :
- $around->{cache}->(@_));
- $_->(@_) for @{$after};
- return unless defined wantarray;
- return wantarray ? @rval : $rval[0];
- }
- }
- elsif (@$before && !@$after) {
- $modifier_table->{cache} = sub {
- $_->(@_) for @{$before};
- return $around->{cache}->(@_);
- }
- }
- elsif (@$after && !@$before) {
- $modifier_table->{cache} = sub {
- my @rval;
- ((defined wantarray) ?
- ((wantarray) ?
- (@rval = $around->{cache}->(@_))
- :
- ($rval[0] = $around->{cache}->(@_)))
- :
- $around->{cache}->(@_));
- $_->(@_) for @{$after};
- return unless defined wantarray;
- return wantarray ? @rval : $rval[0];
- }
- }
- else {
- $modifier_table->{cache} = $around->{cache};
- }
-};
-
-sub wrap {
- my $class = shift;
- my $code = shift;
- (blessed($code) && $code->isa('Class::MOP::Method'))
- || confess "Can only wrap blessed CODE";
- my $modifier_table = {
- cache => undef,
- orig => $code,
- before => [],
- after => [],
- around => {
- cache => $code->body,
- methods => [],
- },
- };
- $_build_wrapped_method->($modifier_table);
- my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
- $method->{modifier_table} = $modifier_table;
- $method;
-}
-
-sub get_original_method {
- my $code = shift;
- $code->{modifier_table}->{orig};
-}
-
-sub add_before_modifier {
- my $code = shift;
- my $modifier = shift;
- unshift @{$code->{modifier_table}->{before}} => $modifier;
- $_build_wrapped_method->($code->{modifier_table});
-}
-
-sub add_after_modifier {
- my $code = shift;
- my $modifier = shift;
- push @{$code->{modifier_table}->{after}} => $modifier;
- $_build_wrapped_method->($code->{modifier_table});
-}
-
-{
- # NOTE:
- # this is another possible canidate for
- # optimization as well. There is an overhead
- # associated with the currying that, if
- # eliminated might make around modifiers
- # more manageable.
- my $compile_around_method = sub {{
- my $f1 = pop;
- return $f1 unless @_;
- my $f2 = pop;
- push @_, sub { $f2->( $f1, @_ ) };
- redo;
- }};
-
- sub add_around_modifier {
- my $code = shift;
- my $modifier = shift;
- unshift @{$code->{modifier_table}->{around}->{methods}} => $modifier;
- $code->{modifier_table}->{around}->{cache} = $compile_around_method->(
- @{$code->{modifier_table}->{around}->{methods}},
- $code->{modifier_table}->{orig}->body
- );
- $_build_wrapped_method->($code->{modifier_table});
- }
-}
-
1;
__END__
subroutines within the particular package. We provide a very basic
introspection interface.
-This also contains the Class::MOP::Method::Wrapped subclass, which
-provides the features for before, after and around method modifiers.
-
=head1 METHODS
=head2 Introspection
=back
-=head1 Class::MOP::Method::Wrapped METHODS
-
-=head2 Construction
-
-=over 4
-
-=item B<wrap (&code)>
-
-=item B<get_original_method>
-
-=back
-
-=head2 Modifiers
-
-=over 4
-
-=item B<add_before_modifier ($code)>
-
-=item B<add_after_modifier ($code)>
-
-=item B<add_around_modifier ($code)>
-
-=back
-
=head1 AUTHORS
Stevan Little E<lt>stevan@iinteractive.comE<gt>
--- /dev/null
+
+package Class::MOP::Method::Accessor;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'blessed', 'weaken';
+
+our $VERSION = '0.02';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Method';
+
+=pod
+
+So, the idea here is that we have an accessor class
+which takes a weak-link to the attribute and can
+generate the actual code ref needed. This might allow
+for more varied approaches.
+
+And if the attribute type can also declare what
+kind of accessor method metaclass it uses, then
+this relationship can be handled by delegation.
+
+=cut
+
+sub new {
+ my $class = shift;
+ my %options = @_;
+
+ (exists $options{attribute})
+ || confess "You must supply an attribute to construct with";
+
+ (exists $options{accessor_type})
+ || confess "You must supply an accessor_type to construct with";
+
+ (blessed($options{attribute}) && $options{attribute}->isa('Class::MOP::Attribute'))
+ || confess "You must supply an attribute which is a 'Class::MOP::Attribute' instance";
+
+ my $self = bless {
+ # from our superclass
+ body => undef,
+ # specific to this subclass
+ attribute => $options{attribute},
+ as_inline => ($options{as_inline} || 0),
+ accessor_type => $options{accessor_type},
+ } => $class;
+
+ # we don't want this creating
+ # a cycle in the code, if not
+ # needed
+ weaken($self->{attribute});
+
+ $self->intialize_body;
+
+ return $self;
+}
+
+## accessors
+
+sub associated_attribute { (shift)->{attribute} }
+sub accessor_type { (shift)->{accessor_type} }
+sub as_inline { (shift)->{as_inline} }
+
+## factory
+
+sub intialize_body {
+ my $self = shift;
+
+ my $method_name = join "_" => (
+ 'generate',
+ $self->accessor_type,
+ 'method',
+ ($self->as_inline ? 'inline' : ())
+ );
+
+ eval {
+ $self->{body} = $self->$method_name();
+ };
+ die $@ if $@;
+}
+
+## generators
+
+sub generate_accessor_method {
+ my $attr = (shift)->associated_attribute;
+ return sub {
+ $attr->set_value($_[0], $_[1]) if scalar(@_) == 2;
+ $attr->get_value($_[0]);
+ };
+}
+
+sub generate_reader_method {
+ my $attr = (shift)->associated_attribute;
+ return sub {
+ confess "Cannot assign a value to a read-only accessor" if @_ > 1;
+ $attr->get_value($_[0]);
+ };
+}
+
+sub generate_writer_method {
+ my $attr = (shift)->associated_attribute;
+ return sub {
+ $attr->set_value($_[0], $_[1]);
+ };
+}
+
+sub generate_predicate_method {
+ my $attr = (shift)->associated_attribute;
+ my $attr_name = $attr->name;
+ return sub {
+ defined Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
+ ->get_meta_instance
+ ->get_slot_value($_[0], $attr_name) ? 1 : 0;
+ };
+}
+
+sub generate_clearer_method {
+ my $attr = (shift)->associated_attribute;
+ my $attr_name = $attr->name;
+ return sub {
+ Class::MOP::Class->initialize(Scalar::Util::blessed($_[0]))
+ ->get_meta_instance
+ ->deinitialize_slot($_[0], $attr_name);
+ };
+}
+
+## Inline methods
+
+
+sub generate_accessor_method_inline {
+ my $attr = (shift)->associated_attribute;
+ my $attr_name = $attr->name;
+ my $meta_instance = $attr->associated_class->instance_metaclass;
+
+ my $code = eval 'sub {'
+ . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]') . ' if scalar(@_) == 2; '
+ . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'")
+ . '}';
+ confess "Could not generate inline accessor because : $@" if $@;
+
+ return $code;
+}
+
+sub generate_reader_method_inline {
+ my $attr = (shift)->associated_attribute;
+ my $attr_name = $attr->name;
+ my $meta_instance = $attr->associated_class->instance_metaclass;
+
+ my $code = eval 'sub {'
+ . 'confess "Cannot assign a value to a read-only accessor" if @_ > 1;'
+ . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'")
+ . '}';
+ confess "Could not generate inline accessor because : $@" if $@;
+
+ return $code;
+}
+
+sub generate_writer_method_inline {
+ my $attr = (shift)->associated_attribute;
+ my $attr_name = $attr->name;
+ my $meta_instance = $attr->associated_class->instance_metaclass;
+
+ my $code = eval 'sub {'
+ . $meta_instance->inline_set_slot_value('$_[0]', "'$attr_name'", '$_[1]')
+ . '}';
+ confess "Could not generate inline accessor because : $@" if $@;
+
+ return $code;
+}
+
+
+sub generate_predicate_method_inline {
+ my $attr = (shift)->associated_attribute;
+ my $attr_name = $attr->name;
+ my $meta_instance = $attr->associated_class->instance_metaclass;
+
+ my $code = eval 'sub {'
+ . 'defined ' . $meta_instance->inline_get_slot_value('$_[0]', "'$attr_name'") . ' ? 1 : 0'
+ . '}';
+ confess "Could not generate inline predicate because : $@" if $@;
+
+ return $code;
+}
+
+sub generate_clearer_method_inline {
+ my $attr = (shift)->associated_attribute;
+ my $attr_name = $attr->name;
+ my $meta_instance = $attr->associated_class->instance_metaclass;
+
+ my $code = eval 'sub {'
+ . $meta_instance->inline_deinitialize_slot('$_[0]', "'$attr_name'")
+ . '}';
+ confess "Could not generate inline clearer because : $@" if $@;
+
+ return $code;
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Method::Accessor - Method Meta Object for accessors
+
+=head1 SYNOPSIS
+
+ # ... more to come later maybe
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=over 4
+
+=item B<new>
+
+=item B<intialize_body>
+
+=item B<accessor_type>
+
+=item B<as_inline>
+
+=item B<associated_attribute>
+
+=item B<generate_accessor_method>
+
+=item B<generate_accessor_method_inline>
+
+=item B<generate_clearer_method>
+
+=item B<generate_clearer_method_inline>
+
+=item B<generate_predicate_method>
+
+=item B<generate_predicate_method_inline>
+
+=item B<generate_reader_method>
+
+=item B<generate_reader_method_inline>
+
+=item B<generate_writer_method>
+
+=item B<generate_writer_method_inline>
+
+=back
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
--- /dev/null
+
+package Class::MOP::Method::Wrapped;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'reftype', 'blessed';
+use Sub::Name 'subname';
+
+our $VERSION = '0.02';
+our $AUTHORITY = 'cpan:STEVAN';
+
+use base 'Class::MOP::Method';
+
+# NOTE:
+# this ugly beast is the result of trying
+# to micro optimize this as much as possible
+# while not completely loosing maintainability.
+# At this point it's "fast enough", after all
+# you can't get something for nothing :)
+my $_build_wrapped_method = sub {
+ my $modifier_table = shift;
+ my ($before, $after, $around) = (
+ $modifier_table->{before},
+ $modifier_table->{after},
+ $modifier_table->{around},
+ );
+ if (@$before && @$after) {
+ $modifier_table->{cache} = sub {
+ $_->(@_) for @{$before};
+ my @rval;
+ ((defined wantarray) ?
+ ((wantarray) ?
+ (@rval = $around->{cache}->(@_))
+ :
+ ($rval[0] = $around->{cache}->(@_)))
+ :
+ $around->{cache}->(@_));
+ $_->(@_) for @{$after};
+ return unless defined wantarray;
+ return wantarray ? @rval : $rval[0];
+ }
+ }
+ elsif (@$before && !@$after) {
+ $modifier_table->{cache} = sub {
+ $_->(@_) for @{$before};
+ return $around->{cache}->(@_);
+ }
+ }
+ elsif (@$after && !@$before) {
+ $modifier_table->{cache} = sub {
+ my @rval;
+ ((defined wantarray) ?
+ ((wantarray) ?
+ (@rval = $around->{cache}->(@_))
+ :
+ ($rval[0] = $around->{cache}->(@_)))
+ :
+ $around->{cache}->(@_));
+ $_->(@_) for @{$after};
+ return unless defined wantarray;
+ return wantarray ? @rval : $rval[0];
+ }
+ }
+ else {
+ $modifier_table->{cache} = $around->{cache};
+ }
+};
+
+sub wrap {
+ my $class = shift;
+ my $code = shift;
+ (blessed($code) && $code->isa('Class::MOP::Method'))
+ || confess "Can only wrap blessed CODE";
+ my $modifier_table = {
+ cache => undef,
+ orig => $code,
+ before => [],
+ after => [],
+ around => {
+ cache => $code->body,
+ methods => [],
+ },
+ };
+ $_build_wrapped_method->($modifier_table);
+ my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
+ $method->{modifier_table} = $modifier_table;
+ $method;
+}
+
+sub get_original_method {
+ my $code = shift;
+ $code->{modifier_table}->{orig};
+}
+
+sub add_before_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ unshift @{$code->{modifier_table}->{before}} => $modifier;
+ $_build_wrapped_method->($code->{modifier_table});
+}
+
+sub add_after_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ push @{$code->{modifier_table}->{after}} => $modifier;
+ $_build_wrapped_method->($code->{modifier_table});
+}
+
+{
+ # NOTE:
+ # this is another possible canidate for
+ # optimization as well. There is an overhead
+ # associated with the currying that, if
+ # eliminated might make around modifiers
+ # more manageable.
+ my $compile_around_method = sub {{
+ my $f1 = pop;
+ return $f1 unless @_;
+ my $f2 = pop;
+ push @_, sub { $f2->( $f1, @_ ) };
+ redo;
+ }};
+
+ sub add_around_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ unshift @{$code->{modifier_table}->{around}->{methods}} => $modifier;
+ $code->{modifier_table}->{around}->{cache} = $compile_around_method->(
+ @{$code->{modifier_table}->{around}->{methods}},
+ $code->{modifier_table}->{orig}->body
+ );
+ $_build_wrapped_method->($code->{modifier_table});
+ }
+}
+
+1;
+
+__END__
+
+=pod
+
+=head1 NAME
+
+Class::MOP::Method::Wrapped - Method Meta Object to handle before/around/after modifiers
+
+=head1 SYNOPSIS
+
+ # ... more to come later maybe
+
+=head1 DESCRIPTION
+
+=head1 METHODS
+
+=head2 Construction
+
+=over 4
+
+=item B<wrap (&code)>
+
+=item B<get_original_method>
+
+=back
+
+=head2 Modifiers
+
+=over 4
+
+=item B<add_before_modifier ($code)>
+
+=item B<add_after_modifier ($code)>
+
+=item B<add_around_modifier ($code)>
+
+=back
+
+=head1 AUTHORS
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+Yuval Kogman E<lt>nothingmuch@woobling.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
+
my %METAS = (
'Class::MOP::Attribute' => Class::MOP::Attribute->meta,
- 'Class::MOP::Attribute::Accessor' => Class::MOP::Attribute::Accessor->meta,
+ 'Class::MOP::Method::Accessor' => Class::MOP::Method::Accessor->meta,
'Class::MOP::Package' => Class::MOP::Package->meta,
'Class::MOP::Module' => Class::MOP::Module->meta,
'Class::MOP::Class' => Class::MOP::Class->meta,
is_deeply(
[ sort { $a->name cmp $b->name } Class::MOP::get_all_metaclass_instances ],
[
- Class::MOP::Attribute->meta,
- Class::MOP::Attribute::Accessor->meta,
+ Class::MOP::Attribute->meta,
Class::MOP::Class->meta,
Class::MOP::Instance->meta,
Class::MOP::Method->meta,
+ Class::MOP::Method::Accessor->meta,
Class::MOP::Method::Wrapped->meta,
Class::MOP::Module->meta,
Class::MOP::Object->meta,
is_deeply(
[ sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ],
[ qw/
- Class::MOP::Attribute
- Class::MOP::Attribute::Accessor
+ Class::MOP::Attribute
Class::MOP::Class
Class::MOP::Instance
Class::MOP::Method
+ Class::MOP::Method::Accessor
Class::MOP::Method::Wrapped
Class::MOP::Module
Class::MOP::Object
[ map { $_->meta->identifier } sort { $a cmp $b } Class::MOP::get_all_metaclass_names() ],
[
"Class::MOP::Attribute-" . $Class::MOP::Attribute::VERSION . "-cpan:STEVAN",
- "Class::MOP::Attribute::Accessor-" . $Class::MOP::Attribute::Accessor::VERSION . "-cpan:STEVAN",
"Class::MOP::Class-" . $Class::MOP::Class::VERSION . "-cpan:STEVAN",
"Class::MOP::Instance-" . $Class::MOP::Instance::VERSION . "-cpan:STEVAN",
"Class::MOP::Method-" . $Class::MOP::Method::VERSION . "-cpan:STEVAN",
+ "Class::MOP::Method::Accessor-" . $Class::MOP::Method::Accessor::VERSION . "-cpan:STEVAN",
"Class::MOP::Method::Wrapped-" . $Class::MOP::Method::Wrapped::VERSION . "-cpan:STEVAN",
"Class::MOP::Module-" . $Class::MOP::Module::VERSION . "-cpan:STEVAN",
"Class::MOP::Object-" . $Class::MOP::Object::VERSION . "-cpan:STEVAN",
::is($meta->get_attribute('$bar'), $BAR_ATTR, '... got the right attribute back for Bar');
::ok($meta->has_method('bar'), '... an accessor has been created');
- ::isa_ok($meta->get_method('bar'), 'Class::MOP::Attribute::Accessor');
+ ::isa_ok($meta->get_method('bar'), 'Class::MOP::Method::Accessor');
}
{
package Baz;
::ok($meta->has_method('get_baz'), '... a reader has been created');
::ok($meta->has_method('set_baz'), '... a writer has been created');
- ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Attribute::Accessor');
- ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Attribute::Accessor');
+ ::isa_ok($meta->get_method('get_baz'), 'Class::MOP::Method::Accessor');
+ ::isa_ok($meta->get_method('set_baz'), 'Class::MOP::Method::Accessor');
}
{
use strict;
use warnings;
-use Test::More tests => 53;
+use Test::More tests => 44;
use Test::Exception;
BEGIN {
set_value
associated_class
- attach_to_class detach_from_class
+ attach_to_class detach_from_class
- generate_accessor_method
- generate_reader_method
- generate_writer_method
- generate_predicate_method
- generate_clearer_method
-
- generate_accessor_method_inline
- generate_reader_method_inline
- generate_writer_method_inline
- generate_predicate_method_inline
- generate_clearer_method_inline
+ accessor_metaclass
process_accessors
install_accessors
my $method = $mixin->get_method($_);
# we want to ignore accessors since
# they will be created with the attrs
- (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'))
+ (blessed($method) && $method->isa('Class::MOP::Method::Accessor'))
? () : ($_ => $method)
} $mixin->get_method_list;
projects / gitmo/Class-MOP.git / commitdiff