'Sub::Name' => '0.02',
'Carp' => '0.01',
'B' => '0',
+ 'SUPER' => '1.11',
},
optional => {
},
Revision history for Perl extension Class-MOP.
-0.13
+0.20
- removed the dependency for Clone since
we no longer to deep-cloning by default.
+ - added dependency for SUPER to support the
+ method modifier code.
+
+ * Class::MOP::Method
+ - added &package_name and &name methods
+ which were formerly private subs in
+ Class::MOP::Class
+
+ * Class::MOP::Method::Wrapped
+ - allows for a method to be wrapped with
+ before, after and around modifiers
+ - added tests and docs for this feature
* Class::MOP::Class
- improved &get_package_variable
+ - methods are now blessed into Class::MOP::Method
+ whenever possible
+ - &has_method now uses new method introspection
+ from Class::MOP::Method to determine where the
+ sub comes from
+ - added methods to install CLOS-style method modifiers
+ - &add_before_method_modifier
+ - &add_after_method_modifier
+ - &add_around_method_modifier
+ - added tests and docs for these
0.12 Thurs. Feb 23, 2006
- reduced the dependency on B, no need to always
-Class::MOP version 0.13
+Class::MOP version 0.20
===========================
See the individual module documentation for more information
use strict;
use warnings;
-our $VERSION = '0.03';
+our $VERSION = '0.04';
use base 'Class::MOP::Attribute';
# this is for an extra attribute constructor
# option, which is to be able to create a
# way for the class to access the history
-__PACKAGE__->meta->add_attribute(
- Class::MOP::Attribute->new('history_accessor' => (
- reader => 'history_accessor',
- init_arg => 'history_accessor',
- predicate => 'has_history_accessor',
- ))
-);
+AttributesWithHistory->meta->add_attribute('history_accessor' => (
+ reader => 'history_accessor',
+ init_arg => 'history_accessor',
+ predicate => 'has_history_accessor',
+));
# this is a place to store the actual
# history of the attribute
-__PACKAGE__->meta->add_attribute(
- Class::MOP::Attribute->new('_history' => (
- accessor => '_history',
- default => sub { {} },
- ))
-);
+AttributesWithHistory->meta->add_attribute('_history' => (
+ accessor => '_history',
+ default => sub { {} },
+));
# generate the methods
}};
}
-sub install_accessors {
- my $self = shift;
- # do as we normall do ...
- $self->SUPER::install_accessors();
+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();
- return;
-}
+});
1;
use Carp 'confess';
use Algorithm::C3;
-our $VERSION = '0.01';
+our $VERSION = '0.02';
use base 'Class::MOP::Class';
}
};
-sub initialize {
- my $class = shift;
- my $meta = $class->SUPER::initialize(@_);
+C3MethodDispatchOrder->meta->add_around_method_modifier('initialize' => sub {
+ my $cont = shift;
+ my $meta = $cont->(@_);
$meta->add_method('AUTOLOAD' => sub {
my $meta = $_[0]->meta;
my $method_name;
$meta->add_method('can' => sub {
$_find_method_in_superclass->($_[0]->meta, $_[1]);
});
- return $meta;
-}
+ return $meta;
+});
sub superclasses {
my $self = shift;
no strict 'refs';
if (@_) {
my @supers = @_;
- @{$self->name . '::SUPERS'} = @supers;
+ @{$self->get_package_variable('@SUPERS')} = @supers;
}
- @{$self->name . '::SUPERS'};
+ @{$self->get_package_variable('@SUPERS')};
}
sub class_precedence_list {
use strict;
use warnings;
-our $VERSION = '0.02';
+our $VERSION = '0.03';
use base 'Class::MOP::Class';
default => 0
));
-sub construct_instance {
- my ($class, %params) = @_;
- $class->{'$:count'}++;
- return $class->SUPER::construct_instance(%params);
-}
+InstanceCountingClass->meta->add_before_method_modifier('construct_instance' => sub {
+ my ($class) = @_;
+ $class->{'$:count'}++;
+});
1;
use strict;
use warnings;
-our $VERSION = '0.01';
+our $VERSION = '0.02';
use base 'Class::MOP::Attribute';
-sub new {
+Perl6Attribute->meta->add_around_method_modifier('new' => sub {
+ my $cont = shift;
my ($class, $attribute_name, %options) = @_;
# extract the sigil and accessor name
$options{default} = sub { [] } if ($sigil eq '@');
$options{default} = sub { {} } if ($sigil eq '%');
- $class->SUPER::new($attribute_name, %options);
-}
+ $cont->($class, $attribute_name, %options);
+});
1;
use Class::MOP::Attribute;
use Class::MOP::Method;
-our $VERSION = '0.13';
+our $VERSION = '0.20';
## ----------------------------------------------------------------------------
## Setting up our environment ...
(reftype($accessor) eq 'HASH')
|| confess "bad accessor/reader/writer/predicate format, must be a HASH ref";
my ($name, $method) = each %{$accessor};
- return ($name, Class::MOP::Attribute::Accessor->new($method));
+ return ($name, Class::MOP::Attribute::Accessor->wrap($method));
}
else {
my $generator = $self->can('generate_' . $type . '_method');
($generator)
|| confess "There is no method generator for the type='$type'";
if (my $method = $self->$generator($self->name)) {
- return ($accessor => Class::MOP::Attribute::Accessor->new($method));
+ return ($accessor => Class::MOP::Attribute::Accessor->wrap($method));
}
confess "Could not create the '$type' method for " . $self->name . " because : $@";
}
|| confess "Your code block must be a CODE reference";
my $full_method_name = ($self->name . '::' . $method_name);
- $method = Class::MOP::Method->new($method) unless blessed($method);
+ $method = $self->method_metaclass->wrap($method) unless blessed($method);
no strict 'refs';
no warnings 'redefine';
*{$full_method_name} = subname $full_method_name => $method;
}
-sub add_method_modifier {
- my ($self, $method_name, $modifier_name, $method_modifier) = @_;
- (defined $method_name && $method_name)
- || confess "You must pass in a method name";
+{
+ my $fetch_and_prepare_method = sub {
+ my ($self, $method_name) = @_;
+ # fetch it locally
+ my $method = $self->get_method($method_name);
+ # if we dont have local ...
+ unless ($method) {
+ # create a local which just calls the SUPER method ...
+ $self->add_method($method_name => sub { $_[0]->super($method_name)->(@_) });
+ $method = $self->get_method($method_name);
+ }
+
+ # now make sure we wrap it properly
+ # (if it isnt already)
+ unless ($method->isa('Class::MOP::Method::Wrapped')) {
+ $method = Class::MOP::Method::Wrapped->wrap($method);
+ $self->add_method($method_name => $method);
+ }
+ return $method;
+ };
+
+ sub add_before_method_modifier {
+ my ($self, $method_name, $method_modifier) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must pass in a method name";
+ my $full_method_modifier_name = ($self->name . '::' . $method_name . ':before');
+ my $method = $fetch_and_prepare_method->($self, $method_name);
+ $method->add_before_modifier(subname $full_method_modifier_name => $method_modifier);
+ }
- my $full_method_modifier_name = ($self->name . '::' . $method_name . ':' . $modifier_name);
-
- my $method = $self->get_method($method_name);
- unless ($method) {
- $self->add_method($method_name => sub { $_[0]->super($method_name)->(@_) });
- $method = $self->get_method($method_name);
+ sub add_after_method_modifier {
+ my ($self, $method_name, $method_modifier) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must pass in a method name";
+ my $full_method_modifier_name = ($self->name . '::' . $method_name . ':after');
+ my $method = $fetch_and_prepare_method->($self, $method_name);
+ $method->add_after_modifier(subname $full_method_modifier_name => $method_modifier);
}
- $method = Class::MOP::Method::Wrapped->wrap($method)
- unless $method->isa('Class::MOP::Method::Wrapped');
-
- $self->add_method($method_name => $method);
-
- my $add_modifier = $method->can('add_' . $modifier_name . '_modifier');
-
- (defined $add_modifier)
- || confess "Modifier type ($modifier_name) not supported";
-
- $add_modifier->($method, subname $full_method_modifier_name => $method_modifier);
+ sub add_around_method_modifier {
+ my ($self, $method_name, $method_modifier) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must pass in a method name";
+ my $full_method_modifier_name = ($self->name . '::' . $method_name . ':around');
+ my $method = $fetch_and_prepare_method->($self, $method_name);
+ $method->add_around_modifier(subname $full_method_modifier_name => $method_modifier);
+ }
+
}
sub alias_method {
|| confess "Your code block must be a CODE reference";
my $full_method_name = ($self->name . '::' . $method_name);
- $method = Class::MOP::Method->new($method) unless blessed($method);
+ $method = $self->method_metaclass->wrap($method) unless blessed($method);
no strict 'refs';
no warnings 'redefine';
return 0 if !defined(&{$sub_name});
my $method = \&{$sub_name};
- $method = Class::MOP::Method->new($method) unless blessed($method);
+ $method = $self->method_metaclass->wrap($method) unless blessed($method);
return 0 if $method->package_name ne $self->name &&
$method->name ne '__ANON__';
correct name, and therefore show up correctly in stack traces and
such.
-=item B<add_method_modifier ($method_name, $modifier_type, $code)>
-
=item B<alias_method ($method_name, $method)>
This will take a C<$method_name> and CODE reference to that
=back
+=head2 Method Modifiers
+
+=over 4
+
+=item B<add_before_method_modifier ($method_name, $code)>
+
+=item B<add_after_method_modifier ($method_name, $code)>
+
+=item B<add_around_method_modifier ($method_name, $code)>
+
+=back
+
=head2 Attributes
It should be noted that since there is no one consistent way to define
# construction
-sub new {
+sub wrap {
my $class = shift;
my $code = shift;
('CODE' eq (reftype($code) || ''))
methods => [],
},
};
- my $method = $class->new(sub {
+ my $method = $class->SUPER::wrap(sub {
$_->(@_) for @{$modifier_table->{before}};
my (@rlist, $rval);
if (defined wantarray) {
=over 4
-=item B<new (&code)>
+=item B<wrap (&code)>
This simply blesses the C<&code> reference passed to it.
use strict;
use warnings;
-use Test::More tests => 120;
+use Test::More tests => 124;
use Test::Exception;
BEGIN {
has_method get_method add_method remove_method alias_method
get_method_list compute_all_applicable_methods find_all_methods_by_name
- add_method_modifier
+ add_before_method_modifier add_after_method_modifier add_around_method_modifier
has_attribute get_attribute add_attribute remove_attribute
get_attribute_list get_attribute_map compute_all_applicable_attributes
}
sub withdraw {
- my ($self, $amount) = @_;
- my $current_balance = $self->balance();
- ($current_balance >= $amount)
+ my ($self, $amount) = @_;
+ my $current_balance = $self->balance();
+ ($current_balance >= $amount)
|| confess "Account overdrawn";
#warn "withdrew $amount from $self";
$self->balance($current_balance - $amount);
init_arg => 'overdraft',
));
- CheckingAccount->meta->add_method_modifier('withdraw' => 'before' => sub {
+ CheckingAccount->meta->add_before_method_modifier('withdraw' => sub {
my ($self, $amount) = @_;
#warn "hello from before";
my $overdraft_amount = $amount - $self->balance();
use_ok('Class::MOP::Method');
}
-my $method = Class::MOP::Method->new(sub { 1 });
+my $method = Class::MOP::Method->wrap(sub { 1 });
is($method->meta, Class::MOP::Method->meta, '... instance and class both lead to the same meta');
is($method->package_name, 'main', '... our package is main::');
isa_ok($meta, 'Class::MOP::Class');
foreach my $method_name (qw(
- new
+ wrap
package_name
name
)) {
}
dies_ok {
- Class::MOP::Method->new()
+ Class::MOP::Method->wrap()
} '... bad args for &wrap';
dies_ok {
- Class::MOP::Method->new('Fail')
+ Class::MOP::Method->wrap('Fail')
} '... bad args for &wrap';
dies_ok {
- Class::MOP::Method->new([])
+ Class::MOP::Method->wrap([])
} '... bad args for &wrap';
\ No newline at end of file
{
my $trace = '';
- my $method = Class::MOP::Method->new(sub { $trace .= 'primary' });
+ my $method = Class::MOP::Method->wrap(sub { $trace .= 'primary' });
isa_ok($method, 'Class::MOP::Method');
$method->();
# test around method
{
- my $method = Class::MOP::Method->new(sub { 4 });
+ my $method = Class::MOP::Method->wrap(sub { 4 });
isa_ok($method, 'Class::MOP::Method');
is($method->(), 4, '... got the right value from the wrapped method');
{
my @tracelog;
- my $method = Class::MOP::Method->new(sub { push @tracelog => 'primary' });
+ my $method = Class::MOP::Method->wrap(sub { push @tracelog => 'primary' });
isa_ok($method, 'Class::MOP::Method');
my $wrapped = Class::MOP::Method::Wrapped->wrap($method);
projects / gitmo/Class-MOP.git / commitdiff