use Carp 'confess';
use Scalar::Util 'blessed', 'reftype';
use Sub::Name 'subname';
+use SUPER ();
our $VERSION = '0.06';
}
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 $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);
+ }
+
+ $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 alias_method {
correct name, and therefore show up correctly in stack traces and
such.
-=item B<add_method_modifier ($modifier_type, $code)>
+=item B<add_method_modifier ($method_name, $modifier_type, $code)>
=item B<alias_method ($method_name, $method)>
bless $code => blessed($class) || $class;
}
-{
- my %MODIFIERS;
-
- sub wrap {
- my $code = shift;
- (blessed($code))
- || confess "Can only ask the package name of a blessed CODE";
- my $modifier_table = {
- orig => $code,
- before => [],
- after => [],
- around => {
- cache => $code,
- methods => [],
- },
- };
- my $method = $code->new(sub {
- $_->(@_) for @{$modifier_table->{before}};
- my (@rlist, $rval);
- if (defined wantarray) {
- if (wantarray) {
- @rlist = $modifier_table->{around}->{cache}->(@_);
- }
- else {
- $rval = $modifier_table->{around}->{cache}->(@_);
- }
- }
- else {
- $modifier_table->{around}->{cache}->(@_);
- }
- $_->(@_) for @{$modifier_table->{after}};
- return unless defined wantarray;
- return wantarray ? @rlist : $rval;
- });
- $MODIFIERS{$method} = $modifier_table;
- $method;
- }
-
- sub add_before_modifier {
- my $code = shift;
- my $modifier = shift;
- (exists $MODIFIERS{$code})
- || confess "You must first wrap your method before adding a modifier";
- (blessed($code))
- || confess "Can only ask the package name of a blessed CODE";
- ('CODE' eq (reftype($code) || ''))
- || confess "You must supply a CODE reference for a modifier";
- unshift @{$MODIFIERS{$code}->{before}} => $modifier;
- }
-
- sub add_after_modifier {
- my $code = shift;
- my $modifier = shift;
- (exists $MODIFIERS{$code})
- || confess "You must first wrap your method before adding a modifier";
- (blessed($code))
- || confess "Can only ask the package name of a blessed CODE";
- ('CODE' eq (reftype($code) || ''))
- || confess "You must supply a CODE reference for a modifier";
- push @{$MODIFIERS{$code}->{after}} => $modifier;
- }
-
- {
- 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;
- (exists $MODIFIERS{$code})
- || confess "You must first wrap your method before adding a modifier";
- (blessed($code))
- || confess "Can only ask the package name of a blessed CODE";
- ('CODE' eq (reftype($code) || ''))
- || confess "You must supply a CODE reference for a modifier";
- unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
- $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
- @{$MODIFIERS{$code}->{around}->{methods}},
- $MODIFIERS{$code}->{orig}
- );
- }
- }
-}
-
# informational
sub package_name {
svref_2object($code)->GV->NAME;
}
+package Class::MOP::Method::Wrapped;
+
+use strict;
+use warnings;
+
+use Carp 'confess';
+use Scalar::Util 'reftype', 'blessed';
+
+our $VERSION = '0.01';
+
+our @ISA = ('Class::MOP::Method');
+
+my %MODIFIERS;
+
+sub wrap {
+ my $class = shift;
+ my $code = shift;
+ (blessed($code) && $code->isa('Class::MOP::Method'))
+ || confess "Can only wrap blessed CODE";
+ my $modifier_table = {
+ orig => $code,
+ before => [],
+ after => [],
+ around => {
+ cache => $code,
+ methods => [],
+ },
+ };
+ my $method = $class->new(sub {
+ $_->(@_) for @{$modifier_table->{before}};
+ my (@rlist, $rval);
+ if (defined wantarray) {
+ if (wantarray) {
+ @rlist = $modifier_table->{around}->{cache}->(@_);
+ }
+ else {
+ $rval = $modifier_table->{around}->{cache}->(@_);
+ }
+ }
+ else {
+ $modifier_table->{around}->{cache}->(@_);
+ }
+ $_->(@_) for @{$modifier_table->{after}};
+ return unless defined wantarray;
+ return wantarray ? @rlist : $rval;
+ });
+ $MODIFIERS{$method} = $modifier_table;
+ $method;
+}
+
+sub add_before_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ (exists $MODIFIERS{$code})
+ || confess "You must first wrap your method before adding a modifier";
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ ('CODE' eq (reftype($code) || ''))
+ || confess "You must supply a CODE reference for a modifier";
+ unshift @{$MODIFIERS{$code}->{before}} => $modifier;
+}
+
+sub add_after_modifier {
+ my $code = shift;
+ my $modifier = shift;
+ (exists $MODIFIERS{$code})
+ || confess "You must first wrap your method before adding a modifier";
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ ('CODE' eq (reftype($code) || ''))
+ || confess "You must supply a CODE reference for a modifier";
+ push @{$MODIFIERS{$code}->{after}} => $modifier;
+}
+
+{
+ 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;
+ (exists $MODIFIERS{$code})
+ || confess "You must first wrap your method before adding a modifier";
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ ('CODE' eq (reftype($code) || ''))
+ || confess "You must supply a CODE reference for a modifier";
+ unshift @{$MODIFIERS{$code}->{around}->{methods}} => $modifier;
+ $MODIFIERS{$code}->{around}->{cache} = $compile_around_method->(
+ @{$MODIFIERS{$code}->{around}->{methods}},
+ $MODIFIERS{$code}->{orig}
+ );
+ }
+}
+
1;
__END__
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More no_plan => 53;
+use Test::Exception;
+
+BEGIN {
+ use_ok('Class::MOP');
+}
+
+{
+ package BankAccount;
+
+ use strict;
+ use warnings;
+ use metaclass;
+
+ use Carp 'confess';
+
+ BankAccount->meta->add_attribute('$:balance' => (
+ accessor => 'balance',
+ init_arg => 'balance',
+ default => 0
+ ));
+
+ sub new { (shift)->meta->new_object(@_) }
+
+ sub deposit {
+ my ($self, $amount) = @_;
+ #warn "deposited $amount in $self";
+ $self->balance($self->balance + $amount);
+ }
+
+ sub withdraw {
+ my ($self, $amount) = @_;
+ my $current_balance = $self->balance();
+ ($current_balance >= $amount)
+ || confess "Account overdrawn";
+ #warn "withdrew $amount from $self";
+ $self->balance($current_balance - $amount);
+ }
+
+ package CheckingAccount;
+
+ use strict;
+ use warnings;
+
+ use base 'BankAccount';
+
+ CheckingAccount->meta->add_attribute('$:overdraft_account' => (
+ accessor => 'overdraft_account',
+ init_arg => 'overdraft',
+ ));
+
+ CheckingAccount->meta->add_method_modifier('withdraw' => 'before' => sub {
+ my ($self, $amount) = @_;
+ #warn "hello from before";
+ my $overdraft_amount = $amount - $self->balance();
+ if ($overdraft_amount > 0) {
+ #warn "overdrawn $overdraft_amount";
+ $self->overdraft_account->withdraw($overdraft_amount);
+ $self->deposit($overdraft_amount);
+ }
+ #warn "balance after overdraft : " . $self->balance;
+ });
+
+ ::ok(CheckingAccount->meta->has_method('withdraw'), '... checking account now has a withdraw method');
+}
+
+
+my $savings_account = BankAccount->new(balance => 250);
+isa_ok($savings_account, 'BankAccount');
+
+is($savings_account->balance, 250, '... got the right savings balance');
+lives_ok {
+ $savings_account->withdraw(50);
+} '... withdrew from savings successfully';
+is($savings_account->balance, 200, '... got the right savings balance after withdrawl');
+
+$savings_account->deposit(150);
+is($savings_account->balance, 350, '... got the right savings balance after deposit');
+
+my $checking_account = CheckingAccount->new(
+ balance => 100,
+ overdraft => $savings_account
+ );
+isa_ok($checking_account, 'CheckingAccount');
+isa_ok($checking_account, 'BankAccount');
+
+is($checking_account->overdraft_account, $savings_account, '... got the right overdraft account');
+
+is($checking_account->balance, 100, '... got the right checkings balance');
+
+lives_ok {
+ $checking_account->withdraw(200);
+} '... withdrew from checking successfully';
+
+is($checking_account->balance, 0, '... got the right checkings balance after withdrawl');
+is($savings_account->balance, 250, '... got the right savings balance after overdraft withdrawl');
+
use strict;
use warnings;
-use Test::More tests => 23;
+use Test::More tests => 26;
use Test::Exception;
BEGIN {
is($trace, 'primary', '... got the right return value from method');
$trace = '';
- my $wrapped = $method->wrap();
+ my $wrapped = Class::MOP::Method::Wrapped->wrap($method);
+ isa_ok($wrapped, 'Class::MOP::Method::Wrapped');
isa_ok($wrapped, 'Class::MOP::Method');
$wrapped->();
is($method->(), 4, '... got the right value from the wrapped method');
- my $wrapped = $method->wrap;
+ my $wrapped = Class::MOP::Method::Wrapped->wrap($method);
+ isa_ok($wrapped, 'Class::MOP::Method::Wrapped');
isa_ok($wrapped, 'Class::MOP::Method');
is($wrapped->(), 4, '... got the right value from the wrapped method');
my $method = Class::MOP::Method->new(sub { push @tracelog => 'primary' });
isa_ok($method, 'Class::MOP::Method');
- my $wrapped = $method->wrap();
+ my $wrapped = Class::MOP::Method::Wrapped->wrap($method);
+ isa_ok($wrapped, 'Class::MOP::Method::Wrapped');
isa_ok($wrapped, 'Class::MOP::Method');
lives_ok {
projects / gitmo/Class-MOP.git / commitdiff