(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 : $@";
}
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype';
use Sub::Name 'subname';
-use B 'svref_2object';
our $VERSION = '0.06';
(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;
# 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 {
(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 {
} if $meta->has_method($method_name);
}
return @methods;
-
}
## Attributes
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__
=head1 METHODS
-=over 4
-
-=item B<wrap (&code)>
+=head2 Introspection
-This simply blesses the C<&code> reference passed to it.
+=over 4
=item B<meta>
=back
+=head2 Construction
+
+=over 4
+
+=item B<new (&code)>
+
+This simply blesses the C<&code> reference passed to it.
+
+=back
+
+=head2 Informational
+
+=over 4
+
+=item B<name>
+
+=item B<package_name>
+
+=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 E<lt>stevan@iinteractive.comE<gt>
# 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
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<mixin ($mixin)>
+
+=back
+
=head1 AUTHOR
Stevan Little E<lt>stevan@iinteractive.comE<gt>
use strict;
use warnings;
-use Test::More tests => 40;
+use Test::More tests => 52;
use Test::Exception;
BEGIN {
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');
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;
use strict;
use warnings;
-use Test::More tests => 9;
+use Test::More tests => 18;
use Test::Exception;
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
--- /dev/null
+#!/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
## Mixin a class without a superclass.
{
package FooMixin;
- use metaclass;
sub foo { 'FooMixin::foo' }
package Foo;
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');
+++ /dev/null
-#!/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');
-
-
-
-
projects / gitmo/Class-MOP.git / commitdiff