From: Stevan Little Date: Wed, 1 Mar 2006 02:48:23 +0000 (+0000) Subject: method modifiers,.. I think the API needs work X-Git-Tag: 0_20~2 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=ddc8edba62632d7708484acedf0884ff354e3579;p=gitmo%2FClass-MOP.git method modifiers,.. I think the API needs work --- diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index 96c8539..b47c419 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -7,6 +7,7 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype'; use Sub::Name 'subname'; +use SUPER (); our $VERSION = '0.06'; @@ -242,7 +243,29 @@ sub add_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 $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 { @@ -717,7 +740,7 @@ other than use B to make sure it is tagged with the correct name, and therefore show up correctly in stack traces and such. -=item B +=item B =item B diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index ef479f3..61b0d3a 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -27,95 +27,6 @@ sub new { 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 { @@ -132,6 +43,106 @@ sub 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__ diff --git a/t/017_add_method_modifier.t b/t/017_add_method_modifier.t new file mode 100644 index 0000000..d7afcd0 --- /dev/null +++ b/t/017_add_method_modifier.t @@ -0,0 +1,102 @@ +#!/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'); + diff --git a/t/031_method_modifiers.t b/t/031_method_modifiers.t index a1d019e..5dee918 100644 --- a/t/031_method_modifiers.t +++ b/t/031_method_modifiers.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 23; +use Test::More tests => 26; use Test::Exception; BEGIN { @@ -22,7 +22,8 @@ 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->(); @@ -53,7 +54,8 @@ BEGIN { 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'); @@ -79,7 +81,8 @@ BEGIN { 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 {