'Sub::Name' => '0.02',
'Carp' => '0.01',
'B' => '0',
- 'SUPER' => '1.11',
},
optional => {
},
Revision history for Perl extension Class-MOP.
-0.20
+0.20 Thurs. March 2, 2006
- 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
+ - added &package_name, &name and
+ &fully_qualified_name methods, some of
which were formerly private subs in
Class::MOP::Class
* Class::MOP::Class
- improved &get_package_variable
+ - &version and &superclasses now use it
- 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
+ - added &find_next_method_by_name which finds the
+ equivalent of SUPER::method_name
0.12 Thurs. Feb 23, 2006
- reduced the dependency on B, no need to always
Build.PL
Changes
Makefile.PL
+META.yml
MANIFEST
MANIFEST.SKIP
-META.yml
README
examples/AttributesWithHistory.pod
+examples/C3MethodDispatchOrder.pod
examples/ClassEncapsulatedAttributes.pod
examples/InsideOutClass.pod
examples/InstanceCountingClass.pod
examples/LazyClass.pod
examples/Perl6Attribute.pod
-examples/C3MethodDispatchOrder.pod
lib/metaclass.pm
lib/Class/MOP.pm
lib/Class/MOP/Attribute.pm
t/014_attribute_introspection.t
t/015_metaclass_inheritance.t
t/016_class_errors_and_edge_cases.t
+t/017_add_method_modifier.t
t/020_attribute.t
t/021_attribute_errors_and_edge_cases.t
t/030_method.t
+t/031_method_modifiers.t
t/040_metaclass.t
t/041_metaclass_incompatability.t
t/050_scala_style_mixin_composition.t
use base 'Class::MOP::Class';
-my $_find_method_in_superclass = sub {
+my $_find_method = sub {
my ($class, $method) = @_;
foreach my $super ($class->class_precedence_list) {
return $super->meta->get_method($method)
my $label = ${$meta->name . '::AUTOLOAD'};
$method_name = (split /\:\:/ => $label)[-1];
}
- my $method = $_find_method_in_superclass->($meta, $method_name);
+ my $method = $_find_method->($meta, $method_name);
(defined $method) || confess "Method ($method_name) not found";
goto &$method;
});
$meta->add_method('can' => sub {
- $_find_method_in_superclass->($_[0]->meta, $_[1]);
+ $_find_method->($_[0]->meta, $_[1]);
});
return $meta;
});
use Carp 'confess';
use Scalar::Util 'blessed', 'reftype';
use Sub::Name 'subname';
-use SUPER ();
+use B 'svref_2object';
our $VERSION = '0.06';
shift @class_list; # shift off $self->name
foreach my $class_name (@class_list) {
- my $meta = $METAS{$class_name};
+ my $meta = $METAS{$class_name} || next;
($self->isa(blessed($meta)))
|| confess $self->name . "->meta => (" . (blessed($self)) . ")" .
" is not compatible with the " .
sub version {
my $self = shift;
- no strict 'refs';
- ${$self->name . '::VERSION'};
+ ${$self->get_package_variable('$VERSION')};
}
# Inheritance
sub superclasses {
my $self = shift;
- no strict 'refs';
if (@_) {
my @supers = @_;
- @{$self->name . '::ISA'} = @supers;
+ @{$self->get_package_variable('@ISA')} = @supers;
}
- @{$self->name . '::ISA'};
+ @{$self->get_package_variable('@ISA')};
}
sub class_precedence_list {
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)->(@_) });
+ # make sure this method even exists ...
+ ($self->find_next_method_by_name($method_name))
+ || confess "The method '$method_name' is not found in the inherience hierarchy for this class";
+ # if so, then create a local which just
+ # calls the next applicable method ...
+ $self->add_method($method_name => sub {
+ $self->find_next_method_by_name($method_name)->(@_);
+ });
$method = $self->get_method($method_name);
}
no strict 'refs';
return 0 if !defined(&{$sub_name});
-
my $method = \&{$sub_name};
- $method = $self->method_metaclass->wrap($method) unless blessed($method);
+ return 0 if (svref_2object($method)->GV->STASH->NAME || '') ne $self->name &&
+ (svref_2object($method)->GV->NAME || '') ne '__ANON__';
- return 0 if $method->package_name ne $self->name &&
- $method->name ne '__ANON__';
+ # at this point we are relatively sure
+ # it is our method, so we bless/wrap it
+ $self->method_metaclass->wrap($method) unless blessed($method);
return 1;
}
next if $seen_class{$class};
$seen_class{$class}++;
# fetch the meta-class ...
- my $meta = $self->initialize($class);;
+ my $meta = $self->initialize($class);
push @methods => {
name => $method_name,
class => $class,
return @methods;
}
+sub find_next_method_by_name {
+ my ($self, $method_name) = @_;
+ (defined $method_name && $method_name)
+ || confess "You must define a method name to find";
+ # keep a record of what we have seen
+ # here, this will handle all the
+ # inheritence issues because we are
+ # using the &class_precedence_list
+ my %seen_class;
+ my @cpl = $self->class_precedence_list();
+ shift @cpl; # discard ourselves
+ foreach my $class (@cpl) {
+ next if $seen_class{$class};
+ $seen_class{$class}++;
+ # fetch the meta-class ...
+ my $meta = $self->initialize($class);
+ return $meta->get_method($method_name)
+ if $meta->has_method($method_name);
+ }
+ return;
+}
+
## Attributes
sub add_attribute {
initialization and destruction where you only want the method called
once, and in the correct order.
+=item B<find_next_method_by_name ($method_name)>
+
+This will return the first method to match a given C<$method_name> in
+the superclasses, this is basically equivalent to calling
+C<SUPER::$method_name>, but it can be dispatched at runtime.
+
=back
=head2 Method Modifiers
+Method modifiers are a concept borrowed from CLOS, in which a method
+can be wrapped with I<before>, I<after> and I<around> method modifiers
+that will be called everytime the method is called.
+
+=head3 How method modifiers work?
+
+Method modifiers work by wrapping the original method and then replacing
+it in the classes symbol table. The wrappers will handle calling all the
+modifiers in the appropariate orders and preserving the calling context
+for the original method.
+
+Each method modifier serves a particular purpose, which may not be
+obvious to users of other method wrapping modules. To start with, the
+return values of I<before> and I<after> modifiers are ignored. This is
+because thier purpose is B<not> to filter the input and output of the
+primary method (this is done with an I<around> modifier). This may seem
+like an odd restriction to some, but doing this allows for simple code
+to be added at the begining or end of a method call without jeapordizing
+the normal functioning of the primary method or placing any extra
+responsibility on the code of the modifier. Of course if you have more
+complex needs, then use the I<around> modifier, which uses a variation
+of continutation passing style to allow for a high degree of flexibility.
+
+Before and around modifiers are called in last-defined-first-called order,
+while after modifiers are called in first-defined-first-called order. So
+the call tree might looks something like this:
+
+ before 2
+ before 1
+ around 2
+ around 1
+ primary
+ after 1
+ after 2
+
+To see examples of using method modifiers, see the following examples
+included in the distribution; F<InstanceCountingClass>, F<Perl6Attribute>,
+F<AttributesWithHistory> and F<C3MethodDispatchOrder>. There is also a
+classic CLOS usage example in the test F<017_add_method_modifier.t>.
+
+=head3 What is the performance impact?
+
+Of course there is a performance cost associated with method modifiers,
+but we have made every effort to make that cost be directly proportional
+to the amount of modifier features you utilize.
+
+The wrapping method does it's best to B<only> do as much work as it
+absolutely needs to. In order to do this we have moved some of the
+performance costs to set-up time, where they are easier to amortize.
+
+All this said, my benchmarks have indicated the following:
+
+ simple wrapper with no modifiers 100% slower
+ simple wrapper with simple before modifier 400% slower
+ simple wrapper with simple after modifier 450% slower
+ simple wrapper with simple around modifier 500-550% slower
+ simple wrapper with all 3 modifiers 1100% slower
+
+These numbers may seem daunting, but you must remember, every feature
+comes with some cost. To put things in perspective, just doing a simple
+C<AUTOLOAD> which does nothing but extract the name of the method called
+and return it costs about 400% over a normal method call.
+
=over 4
=item B<add_before_method_modifier ($method_name, $code)>
+This will wrap the method at C<$method_name> and the supplied C<$code>
+will be passed the C<@_> arguments, and called before the original
+method is called. As specified above, the return value of the I<before>
+method modifiers is ignored, and it's ability to modify C<@_> is
+fairly limited. If you need to do either of these things, use an
+C<around> method modifier.
+
=item B<add_after_method_modifier ($method_name, $code)>
+This will wrap the method at C<$method_name> so that the original
+method will be called, it's return values stashed, and then the
+supplied C<$code> will be passed the C<@_> arguments, and called.
+As specified above, the return value of the I<after> method
+modifiers is ignored, and it cannot modify the return values of
+the original method. If you need to do either of these things, use an
+C<around> method modifier.
+
=item B<add_around_method_modifier ($method_name, $code)>
+This will wrap the method at C<$method_name> so that C<$code>
+will be called and passed the original method as an extra argument
+at the begining of the C<@_> argument list. This is a variation of
+continuation passing style, where the function prepended to C<@_>
+can be considered a continuation. It is up to C<$code> if it calls
+the original method or not, there is no restriction on what the
+C<$code> can or cannot do.
+
=back
=head2 Attributes
svref_2object($code)->GV->NAME;
}
+sub fully_qualified_name {
+ my $code = shift;
+ (blessed($code))
+ || confess "Can only ask the package name of a blessed CODE";
+ $code->package_name . '::' . $code->name;
+}
+
package Class::MOP::Method::Wrapped;
use strict;
use Carp 'confess';
use Scalar::Util 'reftype', 'blessed';
+use Sub::Name 'subname';
our $VERSION = '0.01';
our @ISA = ('Class::MOP::Method');
+# NOTE:
+# this ugly beast is the result of trying
+# to micro optimize this as much as possible
+# while not completely loosing maintainability.
+# At this point it's "fast enough", after all
+# you can't get something for nothing :)
+my $_build_wrapped_method = sub {
+ my $modifier_table = shift;
+ my ($before, $after, $around) = (
+ $modifier_table->{before},
+ $modifier_table->{after},
+ $modifier_table->{around},
+ );
+ if (@$before && @$after) {
+ $modifier_table->{cache} = sub {
+ $_->(@_) for @{$before};
+ my @rval;
+ ((defined wantarray) ?
+ ((wantarray) ?
+ (@rval = $around->{cache}->(@_))
+ :
+ ($rval[0] = $around->{cache}->(@_)))
+ :
+ $around->{cache}->(@_));
+ $_->(@_) for @{$after};
+ return unless defined wantarray;
+ return wantarray ? @rval : $rval[0];
+ }
+ }
+ elsif (@$before && !@$after) {
+ $modifier_table->{cache} = sub {
+ $_->(@_) for @{$before};
+ return $around->{cache}->(@_);
+ }
+ }
+ elsif (@$after && !@$before) {
+ $modifier_table->{cache} = sub {
+ my @rval;
+ ((defined wantarray) ?
+ ((wantarray) ?
+ (@rval = $around->{cache}->(@_))
+ :
+ ($rval[0] = $around->{cache}->(@_)))
+ :
+ $around->{cache}->(@_));
+ $_->(@_) for @{$after};
+ return unless defined wantarray;
+ return wantarray ? @rval : $rval[0];
+ }
+ }
+ else {
+ $modifier_table->{cache} = $around->{cache};
+ }
+};
+
my %MODIFIERS;
sub wrap {
(blessed($code) && $code->isa('Class::MOP::Method'))
|| confess "Can only wrap blessed CODE";
my $modifier_table = {
+ cache => undef,
orig => $code,
before => [],
after => [],
around => {
cache => $code,
- methods => [],
+ methods => [],
},
};
- my $method = $class->SUPER::wrap(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;
- });
+ $_build_wrapped_method->($modifier_table);
+ my $method = $class->SUPER::wrap(sub { $modifier_table->{cache}->(@_) });
$MODIFIERS{$method} = $modifier_table;
$method;
}
('CODE' eq (reftype($code) || ''))
|| confess "You must supply a CODE reference for a modifier";
unshift @{$MODIFIERS{$code}->{before}} => $modifier;
+ $_build_wrapped_method->($MODIFIERS{$code});
}
sub add_after_modifier {
('CODE' eq (reftype($code) || ''))
|| confess "You must supply a CODE reference for a modifier";
push @{$MODIFIERS{$code}->{after}} => $modifier;
+ $_build_wrapped_method->($MODIFIERS{$code});
}
{
+ # NOTE:
+ # this is another possible canidate for
+ # optimization as well. There is an overhead
+ # associated with the currying that, if
+ # eliminated might make around modifiers
+ # more manageable.
my $compile_around_method = sub {{
my $f1 = pop;
return $f1 unless @_;
@{$MODIFIERS{$code}->{around}->{methods}},
$MODIFIERS{$code}->{orig}
);
+ $_build_wrapped_method->($MODIFIERS{$code});
}
}
This simply blesses the C<&code> reference passed to it.
-=item B<wrap>
-
-This wraps an existing method so that it can handle method modifiers.
-
=back
=head2 Informational
=item B<package_name>
+=item B<fully_qualified_name>
+
+=back
+
+=head1 Class::MOP::Method::Wrapped METHODS
+
+=head2 Construction
+
+=over 4
+
+=item B<wrap (&code)>
+
+This simply blesses the C<&code> reference passed to it.
+
=back
=head2 Modifiers
+++ /dev/null
-
-package Class::MOP::SafeMixin;
-
-use strict;
-use warnings;
-
-use Scalar::Util 'blessed';
-use Carp 'confess';
-
-our $VERSION = '0.01';
-
-use base 'Class::MOP::Class';
-
-sub mixin {
- # fetch the metaclass for the
- # caller and the mixin arg
- my $metaclass = shift;
- my $mixin = $metaclass->initialize(shift);
-
- # according to Scala, the
- # the superclass of our class
- # must be a subclass of the
- # superclass of the mixin (see above)
- my ($super_meta) = $metaclass->superclasses();
- my ($super_mixin) = $mixin->superclasses();
- ($super_meta->isa($super_mixin))
- || confess "The superclass must extend a subclass of the superclass of the mixin"
- if defined $super_mixin && defined $super_meta;
-
- # collect all the attributes
- # and clone them so they can
- # associate with the new class
- my @attributes = map {
- $mixin->get_attribute($_)->clone()
- } $mixin->get_attribute_list;
-
- my %methods = map {
- my $method = $mixin->get_method($_);
- # we want to ignore accessors since
- # they will be created with the attrs
- (blessed($method) && $method->isa('Class::MOP::Attribute::Accessor'))
- ? () : ($_ => $method)
- } $mixin->get_method_list;
-
- # NOTE:
- # I assume that locally defined methods
- # and attributes get precedence over those
- # from the mixin.
-
- # add all the attributes in ....
- foreach my $attr (@attributes) {
- $metaclass->add_attribute($attr)
- unless $metaclass->has_attribute($attr->name);
- }
-
- # add all the methods in ....
- foreach my $method_name (keys %methods) {
- $metaclass->alias_method($method_name => $methods{$method_name})
- unless $metaclass->has_method($method_name);
- }
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Class::MOP::SafeMixin - A meta-object for safe mixin-style composition
-
-=head1 SYNOPSIS
-
-=head1 DESCRIPTION
-
-This is a meta-object which provides B<safe> mixin-style composition
-of classes. The key word here is "safe" because we enforce a number
-of rules about mixing in which prevent some of the instability
-inherent in other mixin systems. However, it should be noted that we
-still allow you enough rope with which to shoot yourself in the foot
-if you so desire.
-
-=over 4
-
-=item *
-
-In order to mix classes together, they must inherit from a common
-superclass. This assures at least some level of similarity between
-the classes being mixed together, which should result in a more
-stable end product.
-
-The only exception to this rule is if the class being mixed in has
-no superclasses at all. In this case we assume the mixin is valid.
-
-=item *
-
-Since we enforce a common ancestral relationship, we need to be
-mindful of method and attribute conflicts. The common ancestor
-increases the potential of method conflicts because it is common
-for subclasses to override their parents methods. However, it is
-less common for attributes to be overriden. The way these are
-resolved is to use a Trait/Role-style conflict mechanism.
-
-If two classes are mixed together, any method or attribute conflicts
-will result in a failure of the mixin and a fatal exception. It is
-not possible to resolve a method or attribute conflict dynamically.
-This is because to do so would open the possibility of breaking
-classes in very subtle and dangerous ways, particularly in the area
-of method interdependencies. The amount of implementation knowledge
-which would need to be known by the mixee would (IMO) increase the
-complexity of the feature exponentially for each class mixed in.
-
-However fear not, there is a solution (see below) ...
-
-=item *
-
-Safe mixin's offer the possibility of CLOS style I<before>, I<after>
-and I<around> methods with which method conflicts can be resolved.
-
-A method, which would normally conflict, but which is labeled with
-either a I<before>, I<after> or I<around> attribute, will instead be
-combined with the original method in the way implied by the attribute.
-
-The result of this is a generalized event-handling system for classes.
-Which can be used to create things more specialized, such as plugins
-and decorators.
-
-=back
-
-=head2 What kinda crack are you on ?!?!?!?
-
-This approach may seem crazy, but I am fairly confident that it will
-work, and that it will not tie your hands unnessecarily. All these
-features have been used with certain degrees of success in the object
-systems of other languages, but none (IMO) provided a complete
-solution.
-
-In CLOS, I<before>, I<after> and I<around> methods provide a high
-degree of flexibility for adding behavior to methods, but do not address
-any concerns regarding classes since in CLOS, classes and methods are
-separate components of the system.
-
-In Scala, mixins are restricted by their ancestral relationships, which
-results in a need to have seperate "traits" to get around this restriction.
-In addition, Scala does not seem to have any means of method conflict
-resolution for mixins (at least not that I can find).
-
-In Perl 6, the role system forces manual disambiguation which (as
-mentioned above) can cause issues with method interdependecies when
-composing roles together. This problem will grow exponentially in one
-direction with each role composed and in the other direction with the
-number of roles that role itself is composed of. The result is that the
-complexity of the system becomes unmanagable for all but very simple or
-very shallow roles. Now, this is not to say that roles are unusable, in
-fact, this feature (IMO) promotes good useage of roles by keeping them
-both small and simple. But, the same behaviors cannot be applied to
-class mixins without hitting these barriers all too quickly.
-
-The same too can be said of the original Traits system, with its
-features for aliasing and exclusion of methods.
-
-So after close study of these systems, and in some cases actually
-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<mixin ($mixin)>
-
-=back
-
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
=head1 NAME
-metaclass - a pragma for installing using Class::MOP metaclasses
+metaclass - a pragma for installing and using Class::MOP metaclasses
=head1 SYNOPSIS
use strict;
use warnings;
-use Test::More tests => 124;
+use Test::More tests => 126;
use Test::Exception;
BEGIN {
superclasses class_precedence_list
has_method get_method add_method remove_method alias_method
- get_method_list compute_all_applicable_methods find_all_methods_by_name
+ get_method_list compute_all_applicable_methods
+ find_all_methods_by_name find_next_method_by_name
add_before_method_modifier add_after_method_modifier add_around_method_modifier
use strict;
use warnings;
-use Test::More no_plan => 53;
+use Test::More tests => 17;
use Test::Exception;
BEGIN {
));
sub new { (shift)->meta->new_object(@_) }
-
+
sub deposit {
my ($self, $amount) = @_;
- #warn "deposited $amount in $self";
$self->balance($self->balance + $amount);
}
my $current_balance = $self->balance();
($current_balance >= $amount)
|| confess "Account overdrawn";
- #warn "withdrew $amount from $self";
$self->balance($current_balance - $amount);
}
use strict;
use warnings;
-
+ use metaclass;
+
use base 'BankAccount';
CheckingAccount->meta->add_attribute('$:overdraft_account' => (
CheckingAccount->meta->add_before_method_modifier('withdraw' => 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');
is($checking_account->balance, 100, '... got the right checkings balance');
lives_ok {
- $checking_account->withdraw(200);
+ $checking_account->withdraw(50);
} '... withdrew from checking successfully';
+is($checking_account->balance, 50, '... got the right checkings balance after withdrawl');
+is($savings_account->balance, 350, '... got the right savings balance after checking withdrawl (no overdraft)');
+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');
+is($savings_account->balance, 200, '... got the right savings balance after overdraft withdrawl');
} '... added the before modifier okay';
lives_ok {
- $wrapped->add_around_modifier(sub { push @tracelog => 'around 3'; $_[0]->(); });
+ $wrapped->add_around_modifier(sub { push @tracelog => 'around 1'; $_[0]->(); });
$wrapped->add_around_modifier(sub { push @tracelog => 'around 2'; $_[0]->(); });
- $wrapped->add_around_modifier(sub { push @tracelog => 'around 1'; $_[0]->(); });
+ $wrapped->add_around_modifier(sub { push @tracelog => 'around 3'; $_[0]->(); });
} '... added the around modifier okay';
lives_ok {
- $wrapped->add_after_modifier(sub { push @tracelog => 'after 3' });
+ $wrapped->add_after_modifier(sub { push @tracelog => 'after 1' });
$wrapped->add_after_modifier(sub { push @tracelog => 'after 2' });
- $wrapped->add_after_modifier(sub { push @tracelog => 'after 1' });
+ $wrapped->add_after_modifier(sub { push @tracelog => 'after 3' });
} '... added the after modifier okay';
$wrapped->();
\@tracelog,
[
'before 3', 'before 2', 'before 1', # last-in-first-out order
- 'around 1', 'around 2', 'around 3', # last-in-first-out order
+ 'around 3', 'around 2', 'around 1', # last-in-first-out order
'primary',
- 'after 3', 'after 2', 'after 1', # first-in-first-out order
+ 'after 1', 'after 2', 'after 3', # first-in-first-out order
],
'... got the right tracelog from all our before/around/after methods');
}
+++ /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');
-}
-
-## Mixin a class without a superclass.
-{
- package FooMixin;
- sub foo { 'FooMixin::foo' }
-
- package Foo;
- use metaclass 'Class::MOP::SafeMixin';
- Foo->meta->mixin('FooMixin');
- sub new { (shift)->meta->new_object(@_) }
-}
-
-my $foo = Foo->new();
-isa_ok($foo, 'Foo');
-
-can_ok($foo, 'foo');
-is($foo->foo, 'FooMixin::foo', '... got the right value from the mixin method');
-
-## Mixin a class who shares a common ancestor
-{
- package Baz;
- our @ISA = ('Foo');
- sub baz { 'Baz::baz' }
-
- 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');
-
- package Foo::Bar::Baz;
- our @ISA = ('Foo::Bar');
- eval { Foo::Bar::Baz->meta->mixin('Baz') };
- ::ok(!$@, '... the classes superclass must extend a subclass of the superclass of the mixins');
-}
-
-my $foo_bar_baz = Foo::Bar::Baz->new();
-isa_ok($foo_bar_baz, 'Foo::Bar::Baz');
-isa_ok($foo_bar_baz, 'Foo::Bar');
-isa_ok($foo_bar_baz, 'Foo');
-isa_ok($foo_bar_baz, 'Bar');
-
-can_ok($foo_bar_baz, 'baz');
-is($foo_bar_baz->baz(), 'Baz::baz', '... got the right value from the mixin method');
-
projects / gitmo/Class-MOP.git / commitdiff