From: Stevan Little Date: Tue, 28 Feb 2006 14:41:18 +0000 (+0000) Subject: bunch of stuff X-Git-Tag: 0_20~8 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=de19f1153a5df8765eae928ea430b7acab545554;p=gitmo%2FClass-MOP.git bunch of stuff --- diff --git a/lib/Class/MOP/Attribute.pm b/lib/Class/MOP/Attribute.pm index fa13bf3..7ca2227 100644 --- a/lib/Class/MOP/Attribute.pm +++ b/lib/Class/MOP/Attribute.pm @@ -141,14 +141,14 @@ sub process_accessors { (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->wrap($method)); + return ($name, Class::MOP::Attribute::Accessor->new($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->wrap($method)); + return ($accessor => Class::MOP::Attribute::Accessor->new($method)); } confess "Could not create the '$type' method for " . $self->name . " because : $@"; } diff --git a/lib/Class/MOP/Class.pm b/lib/Class/MOP/Class.pm index efdcab2..542c968 100644 --- a/lib/Class/MOP/Class.pm +++ b/lib/Class/MOP/Class.pm @@ -7,7 +7,6 @@ use warnings; use Carp 'confess'; use Scalar::Util 'blessed', 'reftype'; use Sub::Name 'subname'; -use B 'svref_2object'; our $VERSION = '0.06'; @@ -234,7 +233,9 @@ sub add_method { (reftype($method) && reftype($method) eq 'CODE') || 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); + no strict 'refs'; no warnings 'redefine'; *{$full_method_name} = subname $full_method_name => $method; @@ -247,33 +248,31 @@ sub alias_method { # use reftype here to allow for blessed subs ... (reftype($method) && reftype($method) eq 'CODE') || confess "Your code block must be a CODE reference"; - my $full_method_name = ($self->name . '::' . $method_name); + my $full_method_name = ($self->name . '::' . $method_name); + + $method = Class::MOP::Method->new($method) unless blessed($method); no strict 'refs'; no warnings 'redefine'; *{$full_method_name} = $method; } -{ - - ## private utility functions for has_method - my $_find_subroutine_package_name = sub { eval { svref_2object($_[0])->GV->STASH->NAME } || '' }; - my $_find_subroutine_name = sub { eval { svref_2object($_[0])->GV->NAME } || '' }; +sub has_method { + my ($self, $method_name) = @_; + (defined $method_name && $method_name) + || confess "You must define a method name"; - sub has_method { - my ($self, $method_name) = @_; - (defined $method_name && $method_name) - || confess "You must define a method name"; + my $sub_name = ($self->name . '::' . $method_name); - my $sub_name = ($self->name . '::' . $method_name); - - no strict 'refs'; - return 0 if !defined(&{$sub_name}); - return 0 if $_find_subroutine_package_name->(\&{$sub_name}) ne $self->name && - $_find_subroutine_name->(\&{$sub_name}) ne '__ANON__'; - return 1; - } - + no strict 'refs'; + return 0 if !defined(&{$sub_name}); + + my $method = \&{$sub_name}; + $method = Class::MOP::Method->new($method) unless blessed($method); + + return 0 if $method->package_name ne $self->name && + $method->name ne '__ANON__'; + return 1; } sub get_method { @@ -281,10 +280,10 @@ sub get_method { (defined $method_name && $method_name) || confess "You must define a method name"; + return unless $self->has_method($method_name); + no strict 'refs'; - return \&{$self->name . '::' . $method_name} - if $self->has_method($method_name); - return; # <- make sure to return undef + return \&{$self->name . '::' . $method_name}; } sub remove_method { @@ -355,7 +354,6 @@ sub find_all_methods_by_name { } if $meta->has_method($method_name); } return @methods; - } ## Attributes diff --git a/lib/Class/MOP/Method.pm b/lib/Class/MOP/Method.pm index 0df47d0..c4aa852 100644 --- a/lib/Class/MOP/Method.pm +++ b/lib/Class/MOP/Method.pm @@ -6,24 +6,91 @@ use warnings; use Carp 'confess'; use Scalar::Util 'reftype', 'blessed'; +use B 'svref_2object'; -our $VERSION = '0.01'; +our $VERSION = '0.02'; + +# introspection sub meta { require Class::MOP::Class; Class::MOP::Class->initialize(blessed($_[0]) || $_[0]); } -sub wrap { +# construction + +sub new { my $class = shift; my $code = shift; - (reftype($code) && reftype($code) eq 'CODE') - || confess "You must supply a CODE reference to wrap"; - - bless $code => $class; + || confess "You must supply a CODE reference to bless"; + 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 = { before => [], after => [] }; + my $method = $code->new(sub { + $_->(@_) for @{$modifier_table->{before}}; + # NOTE: + # we actually need to be sure to preserve + # the calling context and call this method + # with the same context too. This just + # requires some bookkeeping code, thats all. + my @rval = $code->(@_); + $_->(@_) for @{$modifier_table->{after}}; + return wantarray ? @rval : $rval[0]; + }); + $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"; + (reftype($modifier) && reftype($modifier) eq '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"; + (reftype($modifier) && reftype($modifier) eq 'CODE') + || confess "You must supply a CODE reference for a modifier"; + push @{$MODIFIERS{$code}->{after}} => $modifier; + } +} + +# informational + +sub package_name { + my $code = shift; + (blessed($code)) + || confess "Can only ask the package name of a blessed CODE"; + svref_2object($code)->GV->STASH->NAME; +} + +sub name { + my $code = shift; + (blessed($code)) + || confess "Can only ask the package name of a blessed CODE"; + svref_2object($code)->GV->NAME; } - + 1; __END__ @@ -50,11 +117,9 @@ Suggestions for this are welcome. =head1 METHODS -=over 4 - -=item B +=head2 Introspection -This simply blesses the C<&code> reference passed to it. +=over 4 =item B @@ -63,6 +128,32 @@ to this class. =back +=head2 Construction + +=over 4 + +=item B + +This simply blesses the C<&code> reference passed to it. + +=back + +=head2 Informational + +=over 4 + +=item B + +=item B + +=back + +=head1 SEE ALSO + +http://dirtsimple.org/2005/01/clos-style-method-combination-for.html + +http://www.gigamonkeys.com/book/object-reorientation-generic-functions.html + =head1 AUTHOR Stevan Little Estevan@iinteractive.comE diff --git a/lib/Class/MOP/SafeMixin.pm b/lib/Class/MOP/SafeMixin.pm index d2a7112..0c823eb 100644 --- a/lib/Class/MOP/SafeMixin.pm +++ b/lib/Class/MOP/SafeMixin.pm @@ -15,7 +15,7 @@ sub mixin { # fetch the metaclass for the # caller and the mixin arg my $metaclass = shift; - my $mixin = (shift)->meta; + my $mixin = $metaclass->initialize(shift); # according to Scala, the # the superclass of our class @@ -165,6 +165,14 @@ implementing said systems, I have come to the see that each on it's own is not robust enough and that combining the best parts of each gives us (what I hope is) a better, safer and saner system. +=head1 METHODS + +=over 4 + +=item B + +=back + =head1 AUTHOR Stevan Little Estevan@iinteractive.comE diff --git a/t/003_methods.t b/t/003_methods.t index 19b242a..9943476 100644 --- a/t/003_methods.t +++ b/t/003_methods.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 40; +use Test::More tests => 52; use Test::Exception; BEGIN { @@ -51,10 +51,17 @@ my $Foo = Class::MOP::Class->initialize('Foo'); my $foo = sub { 'Foo::foo' }; +ok(!UNIVERSAL::isa($foo, 'Class::MOP::Method'), '... our method is not yet blessed'); + lives_ok { $Foo->add_method('foo' => $foo); } '... we added the method successfully'; +isa_ok($foo, 'Class::MOP::Method'); + +is($foo->name, 'foo', '... got the right name for the method'); +is($foo->package_name, 'Foo', '... got the right package name for the method'); + ok($Foo->has_method('foo'), '... Foo->has_method(foo) (defined with Sub::Name)'); is($Foo->get_method('foo'), $foo, '... Foo->get_method(foo) == \&foo'); @@ -71,6 +78,18 @@ ok($Foo->has_method('bling'), '... Foo->has_method(bling) (defined in main:: usi ok($Foo->has_method('bang'), '... Foo->has_method(bang) (defined in main:: using symbol tables and Sub::Name)'); ok($Foo->has_method('evaled_foo'), '... Foo->has_method(evaled_foo) (evaled in main::)'); +# calling get_method blessed them all +isa_ok($_, 'Class::MOP::Method') for ( + \&Foo::FOO_CONSTANT, + \&Foo::bar, + \&Foo::baz, + \&Foo::floob, + \&Foo::blah, + \&Foo::bling, + \&Foo::bang, + \&Foo::evaled_foo, + ); + { package Foo::Aliasing; use metaclass; diff --git a/t/030_method.t b/t/030_method.t index c43cd42..b34212f 100644 --- a/t/030_method.t +++ b/t/030_method.t @@ -3,7 +3,7 @@ use strict; use warnings; -use Test::More tests => 9; +use Test::More tests => 18; use Test::Exception; BEGIN { @@ -11,34 +11,34 @@ BEGIN { use_ok('Class::MOP::Method'); } -{ - my $method = Class::MOP::Method->wrap(sub { 1 }); - is($method->meta, Class::MOP::Method->meta, '... instance and class both lead to the same meta'); -} +my $method = Class::MOP::Method->new(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::'); +is($method->name, '__ANON__', '... our sub name is __ANON__'); my $meta = Class::MOP::Method->meta; isa_ok($meta, 'Class::MOP::Class'); - -{ - my $meta = Class::MOP::Method->meta(); - isa_ok($meta, 'Class::MOP::Class'); - - foreach my $method_name (qw( - wrap - )) { - ok($meta->has_method($method_name), '... Class::MOP::Method->has_method(' . $method_name . ')'); - } +foreach my $method_name (qw( + new + package_name + name + )) { + ok($meta->has_method($method_name), '... Class::MOP::Method->has_method(' . $method_name . ')'); + my $method = $meta->get_method($method_name); + is($method->package_name, 'Class::MOP::Method', '... our package is Class::MOP::Method'); + is($method->name, $method_name, '... our sub name is "' . $method_name . '"'); } dies_ok { - Class::MOP::Method->wrap() + Class::MOP::Method->new() } '... bad args for &wrap'; dies_ok { - Class::MOP::Method->wrap('Fail') + Class::MOP::Method->new('Fail') } '... bad args for &wrap'; dies_ok { - Class::MOP::Method->wrap([]) + Class::MOP::Method->new([]) } '... bad args for &wrap'; \ No newline at end of file diff --git a/t/031_method_modifiers.t b/t/031_method_modifiers.t new file mode 100644 index 0000000..3e8c617 --- /dev/null +++ b/t/031_method_modifiers.t @@ -0,0 +1,44 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More no_plan => 18; +use Test::Exception; + +BEGIN { + use_ok('Class::MOP'); + use_ok('Class::MOP::Method'); +} + +my $trace = ''; + +my $method = Class::MOP::Method->new(sub { $trace .= 'primary' }); +isa_ok($method, 'Class::MOP::Method'); + +$method->(); +is($trace, 'primary', '... got the right return value from method'); +$trace = ''; + +my $wrapped = $method->wrap(); +isa_ok($wrapped, 'Class::MOP::Method'); + +$wrapped->(); +is($trace, 'primary', '... got the right return value from the wrapped method'); +$trace = ''; + +lives_ok { + $wrapped->add_before_modifier(sub { $trace .= 'before -> ' }); +} '... added the before modifier okay'; + +$wrapped->(); +is($trace, 'before -> primary', '... got the right return value from the wrapped method (w/ before)'); +$trace = ''; + +lives_ok { + $wrapped->add_after_modifier(sub { $trace .= ' -> after' }); +} '... added the after modifier okay'; + +$wrapped->(); +is($trace, 'before -> primary -> after', '... got the right return value from the wrapped method (w/ before)'); +$trace = ''; \ No newline at end of file diff --git a/t/300_basic_safe_mixin.t b/t/300_basic_safe_mixin.t index 0694821..8311fd5 100644 --- a/t/300_basic_safe_mixin.t +++ b/t/300_basic_safe_mixin.t @@ -13,7 +13,6 @@ BEGIN { ## Mixin a class without a superclass. { package FooMixin; - use metaclass; sub foo { 'FooMixin::foo' } package Foo; @@ -37,6 +36,21 @@ is($foo->foo, 'FooMixin::foo', '... got the right value from the mixin method'); package Bar; our @ISA = ('Foo'); + package Foo::Baz; + our @ISA = ('Foo'); + eval { Foo::Baz->meta->mixin('Baz') }; + ::ok(!$@, '... the classes superclass must extend a subclass of the superclass of the mixins'); + +} + +my $foo_baz = Foo::Baz->new(); +isa_ok($foo_baz, 'Foo::Baz'); +isa_ok($foo_baz, 'Foo'); + +can_ok($foo_baz, 'baz'); +is($foo_baz->baz(), 'Baz::baz', '... got the right value from the mixin method'); + +{ package Foo::Bar; our @ISA = ('Foo', 'Bar'); diff --git a/t/301_safe_mixin_decorators.t b/t/301_safe_mixin_decorators.t deleted file mode 100644 index 777c318..0000000 --- a/t/301_safe_mixin_decorators.t +++ /dev/null @@ -1,58 +0,0 @@ -#!/usr/bin/perl - -use strict; -use warnings; - -use Test::More no_plan => 1; - -BEGIN { - use_ok('Class::MOP'); - use_ok('Class::MOP::SafeMixin'); -} - -{ - package FooMixin; - use metaclass; - - my %cache; - sub MODIFY_CODE_ATTRIBUTES { - my ($class, $code, @attrs) = @_; - ::diag join ", " => $code, "Attrs: ", @attrs; - $cache{$code} = $attrs[0]; - return (); - } - - sub FETCH_CODE_ATTRIBUTES { $cache{$_[1]} } - - sub foo : before { 'FooMixin::foo::before -> ' } - sub bar : after { ' -> FooMixin::bar::after' } - sub baz : around { - my $method = shift; - my ($self, @args) = @_; - 'FooMixin::baz::around(' . $self->$method(@args) . ')'; - } - - package Foo; - use metaclass 'Class::MOP::SafeMixin'; - - Foo->meta->mixin('FooMixin'); - - sub new { (shift)->meta->new_object(@_) } - - sub foo { 'Foo::foo' } - sub bar { 'Foo::bar' } - sub baz { 'Foo::baz' } -} - -diag attributes::get(\&FooMixin::foo) . "\n"; - -my $foo = Foo->new(); -isa_ok($foo, 'Foo'); - -is($foo->foo(), 'FooMixin::foo::before -> Foo::foo', '... before method worked'); -is($foo->bar(), 'Foo::bar -> FooMixin::bar::after', '... after method worked'); -is($foo->baz(), 'FooMixin::baz::around(Foo::baz)', '... around method worked'); - - - -