Revision history for Perl extension Moose
-0.56
+0.55_02
* Makefile.PL and Moose.pm
- explicitly require Perl 5.8.0+ (Dave Rolsky)
+ * Moose::Util::MetaRole
+ - This simplifies the application of roles to any meta class, as
+ well as the base object class. Reimplemented metaclass traits
+ using this module. (Dave Rolsky)
+
* Moose::Util::TypeConstraints
- Fix warnings from find_type_constraint if the type is not
found (t0m).
=over 4
-=item L<Moose::Cookbook::Extending::Recipe1> - Providing an alternate base object class
+=item L<Moose::Cookbook::Extending::Recipe1> - Moose extension overview
+
+There are quite a number of ways to extend Moose. This recipe explains
+provides an overview of each method, and provides recommendations for
+when each is appropriate.
+
+=item L<Moose::Cookbook::Extending::Recipe2> - Providing a base object class role
+
+Many base object class extensions can be implemented as roles. This
+example shows how to provide a base object class debugging role that
+is applied to any class that uses a notional C<MooseX::Debugging>
+module.
+
+=item L<Moose::Cookbook::Extending::Recipe3> - Providing an alternate base object class
You may find that you want to provide an alternate base object class
along with a meta extension, or maybe you just want to add some
functionality to all your classes without typing C<extends
'MyApp::Base'> over and over.
-=item L<Moose::Cookbook::Extending::Recipe2> - Acting like Moose.pm and providing sugar Moose-style
+=item L<Moose::Cookbook::Extending::Recipe4> - Acting like Moose.pm and providing sugar Moose-style
This recipe shows how to provide a replacement for C<Moose.pm>. You
may want to do this as part of the API for a C<MooseX> module,
=head1 NAME
-Moose::Cookbook::Extending::Recipe1 - Providing an alternate base object class
+Moose::Cookbook::Extending::Recipe - Moose extension overview
-=head1 SYNOPSIS
+=head1 DESCRIPTION
+
+Moose has quite a number of ways in which extensions can hook into
+Moose and change its behavior. Moose also has a lot of behavior that
+can be changed. This recipe will provide an overview of each extension
+method and give you some recommendations on what tools to use.
+
+If you haven't yet read the recipes on metaclasses, go read those
+first. You can't really write Moose extensions without understanding
+the metaclasses, and those recipes also demonstrate some basic
+extensions mechanisms such as metaclass subclasses and traits.
+
+=head2 Playing Nice With Others
+
+One of the goals of this overview is to help you build extensions that
+cooperate well with other extensions. This is especially important if
+you plan to release your extension to CPAN.
+
+Moose comes with several modules that exist to help your write
+cooperative extensions. These are L<Moose::Exporter> and
+L<Moose::Util::MetaRole>. By using these two modules to implement your
+extensions, you will ensure that your extension works with both the
+Moose core features and any other CPAN extension using those modules.
+
+=head1 PARTS OF Moose YOU CAN EXTEND
+
+The types of things you might want to do in Moose extensions broadly
+fall into a few categories.
+
+=head2 Metaclass Extensions
+
+One way of extending Moose is by extending one or more Moose
+metaclasses. For example, in L<Moose::Cookbook::Meta::Recipe4> we saw
+a metaclass subclass that added a C<table> attribute to the
+metaclass. If you were writing an ORM, this would be a logical
+extension.
+
+Many of the Moose extensions on CPAN work by providing an attribute
+metaclass extension. For example, the C<MooseX::AttributeHelpers>
+distro provides a new attribute metaclass that lets you delegate
+behavior to a non-object attribute (a hashref or simple number).
+
+A metaclass extension can be packaged as a subclass or a
+role/trait. If you can, we recommend using traits instead of
+subclasses, since it's generally much easier to combine disparate
+traits then it is to combine a bunch of subclasses.
+
+When your extensions are implemented as roles, you can apply them with
+the L<Moose::Util::MetaRole> module.
+
+=head2 Providing Sugar Subs
+
+As part of a metaclass extension, you may also want to provide some
+sugar subroutines, much like C<Moose.pm> does. Moose provides a helper
+module called L<Moose::Exporter> that makes this much simpler. This
+will be used in several of the extension recipes.
+
+=head2 Object Class Extensions
+
+Another common Moose extension is to change the default object class
+behavior. For example, the C<MooseX::Singleton> extension changes the
+behavior of your objects so that they are singletons. The
+C<MooseX::StrictConstructor> extension makes the constructor reject
+arguments which don't match its attributes.
+
+Object class extensions often also include metaclass extensions. In
+particular, if you want your object extension to work when a class is
+made immutable, you may need to extend some or all of the
+C<Moose::Meta::Instance>, C<Moose::Meta::Method::Constructor>, and
+C<Moose::Meta::Method::Destructor> objects.
+
+The L<Moose::Util::MetaRole> module lets you apply roles to the base
+object class, as well as the meta classes just mentioned.
- package MyApp::Base;
- use Moose;
+=head2 Providing a Role
- extends 'Moose::Object';
+Some extensions come in the form of a role for you to consume. The
+C<MooseX::Object::Pluggable> extension is a great example of this. In
+fact, despite the C<MooseX> name, it does not actually change anything
+about Moose's behavior. Instead, it is just a role that an object
+which wants to be pluggable can consume.
+
+If you are implementing this sort of extension, you don't need to do
+anything special. You simply create a role and document that it should
+be used via the normal C<with> sugar:
+
+ package RoleConsumer;
+
+ use Moose;
+
+ with 'MooseX::My::Role';
+
+=head2 New Types
+
+Another common Moose extension is a new type for the Moose type
+system. In this case, you simply create a type in your module. When
+people load your module, the type is created, and they can refer to it
+by name after that. The C<MooseX::Types::URI> and
+C<MooseX::Types::DateTime> distros are two good examples of how this
+works.
+
+=head1 ROLES VS TRAITS VS SUBCLASSES
+
+It is important to understand that B<roles and traits are the same
+thing>. A role can be used as a trait, and a trait is a role. The only
+thing that distinguishes the two is that a trait is packaged in a way
+that lets Moose resolve a short name to a class name. In other words,
+with a trait, the caller can specify it by a short name like "Big",
+and Moose will resolve it to a class like
+C<MooseX::Embiggen::Meta::Attribute::Role::Big>.
+
+See L<Moose::Cookbook::Meta::Recipe3> and
+L<Moose::Cookbook::Meta::Recipe5> for examples of traits in action. In
+particular, both of these recipes demonstrate the trait resolution
+mechanism.
+
+Implementing an extension as a (set of) metaclass or base object
+role(s) will make your extension more cooperative. It is hard for an
+end-user to effectively combine together multiple metaclass
+subclasses, but it can be very easy to combine roles.
+
+=head1 USING YOUR EXTENSION
+
+There are a number of ways in which an extension can be applied. In
+some cases you can provide multiple ways of consuming your extension.
+
+=head2 Extensions as Metaclass Traits
+
+If your extension is available as a trait, you can ask end users to
+simply specify it in a list of traits. Currently, this only works for
+metaclass and attribute metaclass traits:
+
+ use Moose -traits => [ 'Big', 'Blue' ];
+
+ has 'animal' =>
+ ( traits => [ 'Big', 'Blue' ],
+ ...
+ );
+
+If your extension applies to any other metaclass, or the object base
+class, you cannot use the trait mechanism.
+
+The benefit of the trait mechanism is that is very easy to see where a
+trait is applied in the code, and consumers have fine-grained control
+over what the trait applies to. This is especially true for attribute
+traits, where you can apply the trait to just one attribute in a
+class.
- before 'new' => sub { warn "Making a new " . $_[0] };
+=head2 Extensions as Metaclass (and Base Object) Subclasses
- no Moose;
+Moose does not provide any simple APIs for consumers to use a subclass
+extension, excep for attribute metaclasses. The attribute declaration
+parameters include a C<metaclass> parameter a consumer of your
+extension can use to specify your subclass.
+
+This is one reason why implementing an extension as a subclass can be
+a poor choice. However, you can force the use of certain subclasses at
+import time by calling C<< Moose->init_meta >> for the caller, and
+providing an alternate metaclass or base object class.
+
+If you do want to do this, you should look at using C<Moose::Exporter>
+to re-export the C<Moose.pm> sugar subroutines. When you use
+L<Moose::Exporter> and your exporting class has an C<init_meta>
+method, L<Moose::Exporter> makes sure that this C<init_meta> method
+gets called when your class is imported.
+
+Then in your C<init_meta> you can arrange for the caller to use your
+subclasses:
+
+ package MooseX::Embiggen;
- package MyApp::UseMyBase;
use Moose ();
use Moose::Exporter;
+ use MooseX::Embiggen::Meta::Class;
+ use MooseX::Embiggen::Object;
+
Moose::Exporter->setup_import_methods( also => 'Moose' );
sub init_meta {
- shift;
- Moose->init_meta( @_, base_class => 'MyApp::Object' );
+ shift; # just your package name
+ my %options = @_;
+
+ return Moose->init_meta(
+ for_class => $options{for_class},
+ metaclass => 'MooseX::Embiggen::Meta::Class',
+ base_class => 'MooseX::Embiggen::Object',
+ );
}
-=head1 DESCRIPTION
+=head2 Extensions as Metaclass (and Base Object) Roles
-Often you find that you want to share some behavior between all your
-classes. One way to do that is to make a base class and simply add
-C<S<extends 'MyApp::Base'>> to every class in your
-application. However, that can get tedious. Instead, you can simply
-create your Moose-alike module that sets the base object class to
-C<MyApp::Base> for you.
+Implementing your extensions as metaclass roles makes your extensions
+easy to apply, and cooperative with other metaclass role-based extensions.
-Then, instead of writing C<S<use Moose>> you can write C<S<use
-MyApp::UseMyBase>>.
+Just as with a subclass, you will probably want to package your
+extensions for consumption with a single module that uses
+L<Moose::Exporter>. However, in this case, you will use
+L<Moose::Util::MetaRole> to apply all of your roles. The advantage of
+using this module is that I<it preserves any subclassing or roles
+already applied to the users metaclasses>. This means that your
+extension is cooperative I<by default>, and consumers of your
+extension can easily use it with other role-based extensions.
-In this particular example, our base class issues some debugging
-output every time a new object is created, but you can surely think of
-some more interesting things to do with your own base class.
+ package MooseX::Embiggen;
-This all works because of the magic of L<Moose::Exporter>. When we
-call C<< Moose::Exporter->setup_import_methods( also => 'Moose' ) >>
-it builds an C<import> and C<unimport> method for you. The C<< also =>
-'Moose' >> bit says that we want to export everything that Moose does.
+ use Moose ();
+ use Moose::Exporter;
+ use Moose::Util::MetaRole;
-The C<import> method that gets created will call our C<init_meta>
-method, passing it C<< for_caller => $caller >> as its arguments. The
-C<$caller> is set to the class that actually imported us in the first
-place.
+ use MooseX::Embiggen::Role::Meta::Class;
+ use MooseX::Embiggen::Role::Meta::Attribute;
+ use MooseX::Embiggen::Role::Meta::Method::Constructor
+ use MooseX::Embiggen::Role::Object;
-See the L<Moose::Exporter> docs for more details on its API.
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
-=head1 USING MyApp::UseMyBase
+ sub init_meta {
+ shift; # just your package name
+ my %options = @_;
-To actually use our new base class, we simply use C<MyApp::UseMyBase>
-I<instead> of C<Moose>. We get all the Moose sugar plus our new base
-class.
+ Moose->init_meta(%options);
+
+ my $meta = Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $options{for_class},
+ metaclass_roles => ['MooseX::Embiggen::Role::Meta::Class'],
+ attribute_metaclass_roles =>
+ ['MooseX::Embiggen::Role::Meta::Attribute'],
+ constructor_class_roles =>
+ ['MooseX::Embiggen::Role::Meta::Method::Constructor'],
+ );
+
+ Moose::Util::MetaRole::apply_base_class_roles(
+ for_class => $options{for_class},
+ roles => ['MooseX::Embiggen::Role::Object'],
+ );
+
+ return $meta;
+ }
+
+As you can see from this example, you can use C<Moose::Util::MetaRole>
+to apply roles to any metaclass, as well as the base object class. If
+some other extension has already applied its own roles, they will be
+preserved when your extension applies its roles, and vice versa.
+
+=head2 Providing Sugar
+
+With L<Moose::Exporter>, you can also export your own sugar subs, as
+well as those from other sugar modules:
+
+ package MooseX::Embiggen;
+
+ use Moose ();
+ use Moose::Exporter;
+
+ Moose::Exporter->setup_import_methods(
+ with_caller => ['embiggen'],
+ also => 'Moose',
+ );
+
+ sub init_meta { ... }
+
+ sub embiggen {
+ my $caller = shift;
+ $caller->meta()->embiggen(@_);
+ }
+
+And then the consumer of your extension can use your C<embiggen> sub:
+
+ package Consumer;
+
+ use MooseX::Embiggen;
+
+ extends 'Thing';
+
+ embiggen ...;
+
+This can be combined with metaclass and base class roles quite easily.
+
+=head1 LEGACY EXTENSION METHODOLOGIES
+
+Before the existence of L<Moose::Exporter> and
+L<Moose::Util::MetaRole>, there were a number of other ways to extend
+Moose. In general, these methods were less cooperative, and only
+worked well with a single extension.
+
+These methods include C<metaclass.pm>, C<Moose::Policy> (which uses
+C<metaclass.pm> under the hood), and various hacks to do what
+L<Moose::Exporter> does. Please do not use these for your own
+extensions.
+
+Note that if you write a cooperative extension, it should cooperate
+with older extensions, though older extensions generally do not
+cooperate with each oether.
- package Foo;
+=head1 CONCLUSION
- use MyApp::UseMyBase;
+If you can write your extension as one or more metaclass and base
+object roles, please consider doing so. Make sure to read the docs for
+L<Moose::Exporter> and L<Moose::Util::MetaRole> as well.
- has 'size' => ( is => 'rw' );
+=head2 Caveat
- no MyApp::UseMyBase;
+The L<Moose::Util::MetaRole> API is still considered an experiment,
+and could go away or change in the future.
=head1 AUTHOR
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2008 by Infinity Interactive, Inc.
+Copyright 2008 by Infinity Interactive, Inc.
L<http://www.iinteractive.com>
=head1 NAME
-Moose::Cookbook::Extending::Recipe2 - Acting like Moose.pm and providing sugar Moose-style
+Moose::Cookbook::Extending::Recipe2 - Providing a role for the base object class
=head1 SYNOPSIS
- package MyApp::Mooseish;
+ package MooseX::Debugging;
use strict;
use warnings;
- use Moose ();
use Moose::Exporter;
+ use Moose::Util::MetaRole;
+ use MooseX::Debugging::Role::Object;
- Moose::Exporter->setup_import_methods(
- with_caller => ['has_table'],
- also => 'Moose',
- );
+ Moose::Exporter->setup_import_methods();
sub init_meta {
shift;
- Moose->init_meta( @_, metaclass => 'MyApp::Meta::Class' );
- }
+ my %options = @_;
- sub has_table {
- my $caller = shift;
- $caller->meta()->table(shift);
+ Moose::Util::MetaRole::apply_base_object_roles(
+ for_class => $options{for_class},
+ role => ['MooseX::Debugging::Role::Object'],
+ );
}
-=head1 DESCRIPTION
-
-This recipe expands on the use of L<Moose::Exporter> we saw in
-L<Moose::Cookbook::Extending::Recipe1>. Instead of providing our own
-object base class, we provide our own metaclass class, and we also
-export a sugar subroutine C<has_table()>.
-
-Given the above code, you can now replace all instances of C<use
-Moose> with C<use MyApp::Mooseish>. Similarly, C<no Moose> is now
-replaced with C<no MyApp::Mooseish>.
-
-The C<with_caller> parameter specifies a list of functions that should
-be wrapped before exporting. The wrapper simply ensures that the
-importing package name is the first argument to the function, so we
-can do C<S<my $caller = shift;>>.
-
-See the L<Moose::Exporter> docs for more details on its API.
-=head1 USING MyApp::Mooseish
+ package MooseX::Debugging::Role::Object;
-The purpose of all this code is to provide a Moose-like
-interface. Here's what it would look like in actual use:
+ after 'BUILD' => sub {
+ my $self = shift;
- package MyApp::User;
-
- use MyApp::Mooseish;
-
- has_table 'User';
+ warn "Made a new " . ref $self . " object\n";
+ }
- has 'username' => ( is => 'ro' );
- has 'password' => ( is => 'ro' );
+=head1 DESCRIPTION
- sub login { ... }
+In this example, we provide a role for the base object class that adds
+some simple debugging output. Every time an object is created, it
+spits out a warning saying what type of object it was.
- no MyApp::Mooseish;
+Obviously, a real debugging role would do something more interesting,
+but this recipe is all about how we apply that role.
-All of the normal Moose sugar (C<has()>, C<with()>, etc) is available
-when you C<use MyApp::Mooseish>.
+In this case, with the combination of L<Moose::Exporter> and
+L<Moose::Util::MetaRole>, we ensure that when a module does "S<use
+MooseX::Debugging>", it automatically gets the debugging role applied
+to its base object class.
=head1 AUTHOR
=head1 COPYRIGHT AND LICENSE
-Copyright 2006-2008 by Infinity Interactive, Inc.
+Copyright 2008 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.
-=pod
+=cut
+
--- /dev/null
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Extending::Recipe3 - Providing an alternate base object class
+
+=head1 SYNOPSIS
+
+ package MyApp::Base;
+ use Moose;
+
+ extends 'Moose::Object';
+
+ before 'new' => sub { warn "Making a new " . $_[0] };
+
+ no Moose;
+
+ package MyApp::UseMyBase;
+ use Moose ();
+ use Moose::Exporter;
+
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
+
+ sub init_meta {
+ shift;
+ Moose->init_meta( @_, base_class => 'MyApp::Object' );
+ }
+
+=head1 DESCRIPTION
+
+Often you find that you want to share some behavior between all your
+classes. One way to do that is to make a base class and simply add
+C<S<extends 'MyApp::Base'>> to every class in your
+application. However, that can get tedious. Instead, you can simply
+create your Moose-alike module that sets the base object class to
+C<MyApp::Base> for you.
+
+Then, instead of writing C<S<use Moose>> you can write C<S<use
+MyApp::UseMyBase>>.
+
+In this particular example, our base class issues some debugging
+output every time a new object is created, but you can surely think of
+some more interesting things to do with your own base class.
+
+This all works because of the magic of L<Moose::Exporter>. When we
+call C<< Moose::Exporter->setup_import_methods( also => 'Moose' ) >>
+it builds an C<import> and C<unimport> method for you. The C<< also =>
+'Moose' >> bit says that we want to export everything that Moose does.
+
+The C<import> method that gets created will call our C<init_meta>
+method, passing it C<< for_caller => $caller >> as its arguments. The
+C<$caller> is set to the class that actually imported us in the first
+place.
+
+See the L<Moose::Exporter> docs for more details on its API.
+
+=head1 USING MyApp::UseMyBase
+
+To actually use our new base class, we simply use C<MyApp::UseMyBase>
+I<instead> of C<Moose>. We get all the Moose sugar plus our new base
+class.
+
+ package Foo;
+
+ use MyApp::UseMyBase;
+
+ has 'size' => ( is => 'rw' );
+
+ no MyApp::UseMyBase;
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch@urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 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
--- /dev/null
+
+=pod
+
+=head1 NAME
+
+Moose::Cookbook::Extending::Recipe4 - Acting like Moose.pm and providing sugar Moose-style
+
+=head1 SYNOPSIS
+
+ package MyApp::Mooseish;
+
+ use strict;
+ use warnings;
+
+ use Moose ();
+ use Moose::Exporter;
+
+ Moose::Exporter->setup_import_methods(
+ with_caller => ['has_table'],
+ also => 'Moose',
+ );
+
+ sub init_meta {
+ shift;
+ Moose->init_meta( @_, metaclass => 'MyApp::Meta::Class' );
+ }
+
+ sub has_table {
+ my $caller = shift;
+ $caller->meta()->table(shift);
+ }
+
+=head1 DESCRIPTION
+
+This recipe expands on the use of L<Moose::Exporter> we saw in
+L<Moose::Cookbook::Extending::Recipe1>. Instead of providing our own
+object base class, we provide our own metaclass class, and we also
+export a sugar subroutine C<has_table()>.
+
+Given the above code, you can now replace all instances of C<use
+Moose> with C<use MyApp::Mooseish>. Similarly, C<no Moose> is now
+replaced with C<no MyApp::Mooseish>.
+
+The C<with_caller> parameter specifies a list of functions that should
+be wrapped before exporting. The wrapper simply ensures that the
+importing package name is the first argument to the function, so we
+can do C<S<my $caller = shift;>>.
+
+See the L<Moose::Exporter> docs for more details on its API.
+
+=head1 USING MyApp::Mooseish
+
+The purpose of all this code is to provide a Moose-like
+interface. Here's what it would look like in actual use:
+
+ package MyApp::User;
+
+ use MyApp::Mooseish;
+
+ has_table 'User';
+
+ has 'username' => ( is => 'ro' );
+ has 'password' => ( is => 'ro' );
+
+ sub login { ... }
+
+ no MyApp::Mooseish;
+
+All of the normal Moose sugar (C<has()>, C<with()>, etc) is available
+when you C<use MyApp::Mooseish>.
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch@urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006-2008 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.
+
+=pod
use Carp qw( confess );
use Class::MOP;
use List::MoreUtils qw( first_index uniq );
+use Moose::Util::MetaRole;
use Sub::Exporter;
$did_init_meta = 1;
}
- if ($did_init_meta) {
+ if ( $did_init_meta && @{$traits} ) {
_apply_meta_traits( $CALLER, $traits );
}
- elsif ( $traits && @{$traits} ) {
+ elsif ( @{$traits} ) {
confess
"Cannot provide traits when $class does not have an init_meta() method";
}
sub _strip_traits {
my $idx = first_index { $_ eq '-traits' } @_;
- return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
+ return ( [], @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
my $traits = $_[ $idx + 1 ];
sub _apply_meta_traits {
my ( $class, $traits ) = @_;
- return
- unless $traits && @$traits;
+ return unless @{$traits};
my $meta = $class->meta();
'Cannot determine metaclass type for trait application . Meta isa '
. ref $meta;
- # We can only call does_role() on Moose::Meta::Class objects, and
- # we can only do that on $meta->meta() if it has already had at
- # least one trait applied to it. By default $meta->meta() returns
- # a Class::MOP::Class object (not a Moose::Meta::Class).
- my @traits = grep {
- $meta->meta()->can('does_role')
- ? not $meta->meta()->does_role($_)
- : 1
- }
- map { Moose::Util::resolve_metatrait_alias( $type => $_ ) } @$traits;
+ my @resolved_traits
+ = map { Moose::Util::resolve_metatrait_alias( $type => $_ ) }
+ @$traits;
- return unless @traits;
+ return unless @resolved_traits;
- Moose::Util::apply_all_roles_with_method( $meta,
- 'apply_to_metaclass_instance', \@traits );
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $class,
+ metaclass_roles => \@resolved_traits,
+ );
}
sub _get_caller {
default => sub { [] }
));
+__PACKAGE__->meta->add_attribute('constructor_class' => (
+ accessor => 'constructor_class',
+ default => sub { 'Moose::Meta::Method::Constructor' }
+));
+
+__PACKAGE__->meta->add_attribute('destructor_class' => (
+ accessor => 'destructor_class',
+ default => sub { 'Moose::Meta::Method::Destructor' }
+));
+
sub initialize {
my $class = shift;
my $pkg = shift;
return undef;
}
+# Right now, this method does not handle the case where two
+# metaclasses differ only in roles applied against a common parent
+# class. This can happen fairly easily when ClassA applies metaclass
+# Role1, and then a subclass, ClassB, applies a metaclass Role2. In
+# reality, the way to resolve the problem is to apply Role1 to
+# ClassB's metaclass. However, we cannot currently detect this, and so
+# we simply fail to fix the incompatibility.
+#
+# The algorithm for fixing it is not that complicated.
+#
+# First, we see if the two metaclasses share a common parent (probably
+# Moose::Meta::Class).
+#
+# Second, we see if the metaclasses only differ in terms of roles
+# applied. This second point is where things break down. There is no
+# easy way to determine if the difference is from roles only. To do
+# that, we'd need to able to reliably determine the origin of each
+# method and attribute in each metaclass. If all the unshared methods
+# & attributes come from roles, and there is no name collision, then
+# we can apply the missing roles to the child's metaclass.
+#
+# Tracking the origin of these things will require some fairly
+# invasive changes to various parts of Moose & Class::MOP.
+#
+# For now, the workaround is for ClassB to subclass ClassA _and then_
+# apply metaclass roles to its metaclass.
sub _fix_metaclass_incompatability {
my ($self, @superclasses) = @_;
+
foreach my $super (@superclasses) {
# don't bother if it does not have a meta.
- my $meta = Class::MOP::Class->initialize($super) or next;
- next unless $meta->isa("Class::MOP::Class");
+ my $super_meta = Class::MOP::Class->initialize($super) or next;
+ next unless $super_meta->isa("Class::MOP::Class");
# get the name, make sure we take
# immutable classes into account
- my $super_meta_name = ($meta->is_immutable
- ? $meta->get_mutable_metaclass_name
- : ref($meta));
+ my $super_meta_name
+ = $super_meta->is_immutable
+ ? $super_meta->get_mutable_metaclass_name
+ : ref($super_meta);
- # but if we have anything else,
- # we need to check it out ...
- unless (# see if of our metaclass is incompatible
+ next if
+ # if our metaclass is compatible
$self->isa($super_meta_name)
and
- # and see if our instance metaclass is incompatible
- $self->instance_metaclass->isa($meta->instance_metaclass)
- ) {
- if ( $meta->isa(ref($self)) ) {
- unless ( $self->is_pristine ) {
- confess "Not reinitializing metaclass for " . $self->name . ", it isn't pristine";
- }
- # also check values %{ $self->get_method_map } for any generated methods
-
- # NOTE:
- # We might want to consider actually
- # transfering any attributes from the
- # original meta into this one, but in
- # general you should not have any there
- # at this point anyway, so it's very
- # much an obscure edge case anyway
- $self = $meta->reinitialize(
- $self->name,
- attribute_metaclass => $meta->attribute_metaclass,
- method_metaclass => $meta->method_metaclass,
- instance_metaclass => $meta->instance_metaclass,
- );
- } else {
- # this will be called soon enough, for now we let it slide
- # $self->check_metaclass_compatability()
- }
+ # and our instance metaclass is also compatible then no
+ # fixes are needed
+ $self->instance_metaclass->isa( $super_meta->instance_metaclass );
+
+ next unless $super_meta->isa( ref($self) );
+
+ unless ( $self->is_pristine ) {
+ confess "Not reinitializing metaclass for "
+ . $self->name
+ . ", it isn't pristine";
}
+
+ $self = $super_meta->reinitialize(
+ $self->name,
+ attribute_metaclass => $super_meta->attribute_metaclass,
+ method_metaclass => $super_meta->method_metaclass,
+ instance_metaclass => $super_meta->instance_metaclass,
+ );
}
+
return $self;
}
my $self = shift;
$self->SUPER::make_immutable
(
- constructor_class => 'Moose::Meta::Method::Constructor',
- destructor_class => 'Moose::Meta::Method::Destructor',
+ constructor_class => $self->constructor_class,
+ destructor_class => $self->destructor_class,
inline_destructor => 1,
# NOTE:
# no need to do this,
+++ /dev/null
-package Moose::Meta::Role::Application::ToMetaclassInstance;
-
-use strict;
-use warnings;
-use metaclass;
-
-use Scalar::Util 'blessed';
-
-our $VERSION = '0.55_01';
-$VERSION = eval $VERSION;
-our $AUTHORITY = 'cpan:STEVAN';
-
-use base 'Moose::Meta::Role::Application::ToClass';
-
-__PACKAGE__->meta->add_attribute('rebless_params' => (
- reader => 'rebless_params',
- default => sub { {} }
-));
-
-my %ANON_CLASSES;
-
-sub apply {
- my ( $self, $role, $meta ) = @_;
-
- my $anon_role_key = (blessed($meta) . $role->name);
-
- my $class;
- if (exists $ANON_CLASSES{$anon_role_key} && defined $ANON_CLASSES{$anon_role_key}) {
- $class = $ANON_CLASSES{$anon_role_key};
- }
- else {
- my $metaclass_class
- = ( ref $meta )->can('create_anon_class')
- ? ref $meta
- : 'Moose::Meta::Class';
- $class = $metaclass_class->create_anon_class(
- superclasses => [ blessed($meta) ],
- );
-
- $ANON_CLASSES{$anon_role_key} = $class;
- $self->SUPER::apply( $role, $class );
- }
-
- $class->rebless_instance( $meta, %{ $self->rebless_params } );
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Moose::Meta::Role::Application::ToMetaclassInstance - Compose a role into a metaclass instance
-
-=head1 DESCRIPTION
-
-=head2 METHODS
-
-=over 4
-
-=item B<new>
-
-=item B<meta>
-
-=item B<apply>
-
-=item B<rebless_params>
-
-=back
-
-=head1 BUGS
-
-All complex software has bugs lurking in it, and this module is no
-exception. If you find a bug please either email me, or add the bug
-to cpan-RT.
-
-=head1 AUTHOR
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2006-2008 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
-
}
else {
$meta = $metaclass->initialize($role);
- $meta->alias_method('meta' => sub { $meta });
+
+ $meta->add_method(
+ 'meta' => sub {
+ # re-initialize so it inherits properly
+ $metaclass->initialize( ref($_[0]) || $_[0] );
+ }
+ );
}
return $meta;
sub apply_all_roles {
my $applicant = shift;
- apply_all_roles_with_method( $applicant, 'apply', [@_] );
-}
-
-sub apply_all_roles_with_method {
- my ( $applicant, $apply_method, $role_list ) = @_;
-
- confess "Must specify at least one role to apply to $applicant"
- unless @$role_list;
+ confess "Must specify at least one role to apply to $applicant" unless @_;
- my $roles = Data::OptList::mkopt($role_list);
+ my $roles = Data::OptList::mkopt( [@_] );
my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
if ( scalar @$roles == 1 ) {
my ( $role, $params ) = @{ $roles->[0] };
- $role->meta->$apply_method( $meta,
- ( defined $params ? %$params : () ) );
+ $role->meta->apply( $meta, ( defined $params ? %$params : () ) );
}
else {
- Moose::Meta::Role->combine( @$roles )->$apply_method($meta);
+ Moose::Meta::Role->combine( @$roles )->apply($meta);
}
}
C<@roles> will be pre-processed through L<Data::OptList::mkopt>
to allow for the additional arguments to be passed.
-=item B<apply_all_roles_with_method ($applicant, $method, @roles)>
-
-This function works just like C<apply_all_roles()>, except it allows
-you to specify what method will be called on the role metaclass when
-applying it to the C<$applicant>. This exists primarily so one can use
-the C<< Moose::Meta::Role->apply_to_metaclass_instance() >> method.
-
=item B<get_all_attribute_values($meta, $instance)>
Returns the values of the C<$instance>'s fields keyed by the attribute names.
--- /dev/null
+package Moose::Util::MetaRole;
+
+use strict;
+use warnings;
+
+use List::MoreUtils qw( all );
+
+sub apply_metaclass_roles {
+ my %options = @_;
+
+ my $for = $options{for_class};
+
+ my $meta = _make_new_metaclass( $for, \%options );
+
+ for my $tor_class ( grep { $options{ $_ . '_roles' } }
+ qw( constructor_class destructor_class ) ) {
+
+ my $class = _make_new_class(
+ $meta->$tor_class(),
+ $options{ $tor_class . '_roles' }
+ );
+
+ $meta->$tor_class($class);
+ }
+
+ return $meta;
+}
+
+sub _make_new_metaclass {
+ my $for = shift;
+ my $options = shift;
+
+ return $for->meta()
+ unless grep { exists $options->{ $_ . '_roles' } }
+ qw(
+ metaclass
+ attribute_metaclass
+ method_metaclass
+ instance_metaclass
+ );
+
+ my $new_metaclass
+ = _make_new_class( ref $for->meta(), $options->{metaclass_roles} );
+
+ my $old_meta = $for->meta();
+
+ # This could get called for a Moose::Meta::Role as well as a Moose::Meta::Class
+ my %classes = map {
+ $_ => _make_new_class( $old_meta->$_(), $options->{ $_ . '_roles' } )
+ }
+ grep { $old_meta->can($_) }
+ qw(
+ attribute_metaclass
+ method_metaclass
+ instance_metaclass
+ );
+
+ return $new_metaclass->reinitialize( $for, %classes );
+}
+
+sub apply_base_class_roles {
+ my %options = @_;
+
+ my $for = $options{for_class};
+
+ my $meta = $for->meta();
+
+ my $new_base = _make_new_class(
+ $for,
+ $options{roles},
+ [ $meta->superclasses() ],
+ );
+
+ $meta->superclasses($new_base)
+ if $new_base ne $meta->name();
+}
+
+sub _make_new_class {
+ my $existing_class = shift;
+ my $roles = shift;
+ my $superclasses = shift || [$existing_class];
+
+ return $existing_class unless $roles;
+
+ my $meta = $existing_class->meta();
+
+ return $existing_class
+ if $meta->can('does_role') && all { $meta->does_role($_) } @{$roles};
+
+ return Moose::Meta::Class->create_anon_class(
+ superclasses => $superclasses,
+ roles => $roles,
+ cache => 1,
+ )->name();
+}
+
+1;
+
+__END__
+
+=head1 NAME
+
+Moose::Util::MetaRole - Apply roles to any metaclass, as well as the object base class
+
+=head1 SYNOPSIS
+
+ package MyApp::Moose;
+
+ use strict;
+ use warnings;
+
+ use Moose ();
+ use Moose::Exporter;
+ use Moose::Util::Meta::Role;
+
+ use MyApp::Role::Meta::Class;
+ use MyApp::Role::Meta::Method::Constructor;
+ use MyApp::Role::Object;
+
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
+
+ sub init_meta {
+ shift;
+ my %options = @_;
+
+ Moose->init_meta(%options);
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $options{for_class},
+ metaclass_roles => ['MyApp::Role::Meta::Class'],
+ constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'],
+ );
+
+ Moose::Util::MetaRole::apply_base_class_roles(
+ for_class => $options{for_class},
+ roles => ['MyApp::Role::Object'],
+ );
+
+ return $options{for_class}->meta();
+ }
+
+=head1 DESCRIPTION
+
+B<The whole concept behind this module is still considered
+experimental, and it could go away in the future!>
+
+This utility module is designed to help authors of Moose extensions
+write extensions that are able to cooperate with other Moose
+extensions. To do this, you must write your extensions as roles, which
+can then be dynamically applyied to the caller's metaclasses.
+
+This module makes sure to preserve any existing superclasses and roles
+already set for the meta objects, which means that any number of
+extensions can apply roles in any order.
+
+=head1 USAGE
+
+B<It is very important that you only call this module's functions when
+your module is imported by the caller>. The process of applying roles
+to the metaclass reinitializes the metaclass object, which wipes out
+any existing attributes already defined. However, as long as you do
+this when your module is imported, the caller should not have any
+attributes defined yet.
+
+The easiest way to ensure that this happens is to use
+L<Moose::Exporter> and provide an C<init_meta> method that will be
+called when imported.
+
+=head1 FUNCTIONS
+
+This module provides two functions.
+
+=head2 apply_metaclass_roles( ... )
+
+This function will apply roles to one or more metaclasses for the
+specified class. It accepts the following parameters:
+
+=over 4
+
+=item * for_class => $name
+
+This specifies the class for which to alter the meta classes.
+
+=item * metaclass_roles => \@roles
+
+=item * attribute_metaclass_roles => \@roles
+
+=item * method_metaclass_roles => \@roles
+
+=item * instance_metaclass_roles => \@roles
+
+=item * constructor_class_roles => \@roles
+
+=item * destructor_class_roles => \@roles
+
+These parameter all specify one or more roles to be applied to the
+specified metaclass. You can pass any or all of these parameters at
+once.
+
+=back
+
+=head2 apply_base_class_roles( for_class => $class, roles => \@roles )
+
+This function will apply the specified roles to the object's base class.
+
+=head1 PROBLEMS WITH METACLASS ROLES AND SUBCLASS
+
+Because of the way this module works, there is an ordering problem
+which occurs in certain situations. This sequence of events causes an
+error:
+
+=over 4
+
+=item 1.
+
+There is a class (ClassA) which uses some extension(s) that apply
+roles to the metaclass.
+
+=item 2.
+
+You have another class (ClassB) which wants to subclass ClassA and
+apply some more extensions.
+
+=back
+
+Normally, the call to C<extends> will happen at run time, I<after> the
+additional extensions are applied. This causes an error when we try to
+make the metaclass for ClassB compatible with the metaclass for
+ClassA.
+
+We hope to be able to fix this in the future.
+
+For now the workaround is for ClassB to make sure it extends ClassA
+I<before> it loads extensions:
+
+ package ClassB;
+
+ use Moose;
+
+ BEGIN { extends 'ClassA' }
+
+ use MooseX::SomeExtension;
+
+=head1 AUTHOR
+
+Dave Rolsky E<lt>autarch@urth.orgE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2008 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
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 59;
+
+use Moose::Util::MetaRole;
+
+
+{
+ package My::Meta::Class;
+ use Moose;
+ extends 'Moose::Meta::Class';
+}
+
+{
+ package My::Meta::Attribute;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
+}
+
+{
+ package My::Meta::Method;
+ use Moose;
+ extends 'Moose::Meta::Method';
+}
+
+{
+ package My::Meta::Instance;
+ use Moose;
+ extends 'Moose::Meta::Instance';
+}
+
+{
+ package My::Meta::MethodConstructor;
+ use Moose;
+ extends 'Moose::Meta::Method::Constructor';
+}
+
+{
+ package My::Meta::MethodDestructor;
+ use Moose;
+ extends 'Moose::Meta::Method::Destructor';
+}
+
+{
+ package Role::Foo;
+ use Moose::Role;
+ has 'foo' => ( is => 'ro', default => 10 );
+}
+
+{
+ package My::Class;
+
+ use Moose;
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class->meta()' );
+ is( My::Class->meta()->foo(), 10,
+ '... and call foo() on that meta object' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ attribute_metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class->meta()'s attribute metaclass} );
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ '... My::Class->meta() still does Role::Foo' );
+
+ My::Class->meta()->add_attribute( 'size', is => 'ro' );
+ is( My::Class->meta()->get_attribute('size')->foo(), 10,
+ '... call foo() on an attribute metaclass object' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ method_metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class->meta()'s method metaclass} );
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ '... My::Class->meta() still does Role::Foo' );
+ ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+
+ My::Class->meta()->add_method( 'bar' => sub { 'bar' } );
+ is( My::Class->meta()->get_method('bar')->foo(), 10,
+ '... call foo() on a method metaclass object' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ instance_metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class->meta()'s instance metaclass} );
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ '... My::Class->meta() still does Role::Foo' );
+ ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+ ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s method metaclass still does Role::Foo} );
+
+ is( My::Class->meta()->get_meta_instance()->foo(), 10,
+ '... call foo() on an instance metaclass object' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ constructor_class_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class->meta()'s constructor class} );
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ '... My::Class->meta() still does Role::Foo' );
+ ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+ ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s method metaclass still does Role::Foo} );
+ ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
+
+ # Actually instantiating the constructor class is too freaking hard!
+ ok( My::Class->meta()->constructor_class()->can('foo'),
+ '... constructor class has a foo method' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ destructor_class_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->destructor_class()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class->meta()'s destructor class} );
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ '... My::Class->meta() still does Role::Foo' );
+ ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s attribute metaclass still does Role::Foo} );
+ ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s method metaclass still does Role::Foo} );
+ ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s instance metaclass still does Role::Foo} );
+ ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
+ q{... My::Class->meta()'s constructor class still does Role::Foo} );
+
+ # same problem as the constructor class
+ ok( My::Class->meta()->destructor_class()->can('foo'),
+ '... destructor class has a foo method' );
+}
+
+{
+ Moose::Util::MetaRole::apply_base_class_roles(
+ for_class => 'My::Class',
+ roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class base class' );
+ is( My::Class->new()->foo(), 10,
+ '... call foo() on a My::Class object' );
+}
+
+{
+ package My::Class2;
+
+ use Moose;
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class2',
+ metaclass_roles => ['Role::Foo'],
+ attribute_metaclass_roles => ['Role::Foo'],
+ method_metaclass_roles => ['Role::Foo'],
+ instance_metaclass_roles => ['Role::Foo'],
+ constructor_class_roles => ['Role::Foo'],
+ destructor_class_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class2->meta()->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class2->meta()' );
+ is( My::Class2->meta()->foo(), 10,
+ '... and call foo() on that meta object' );
+ ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} );
+ My::Class2->meta()->add_attribute( 'size', is => 'ro' );
+
+ is( My::Class2->meta()->get_attribute('size')->foo(), 10,
+ '... call foo() on an attribute metaclass object' );
+
+ ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s method metaclass} );
+
+ My::Class2->meta()->add_method( 'bar' => sub { 'bar' } );
+ is( My::Class2->meta()->get_method('bar')->foo(), 10,
+ '... call foo() on a method metaclass object' );
+
+ ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
+ is( My::Class2->meta()->get_meta_instance()->foo(), 10,
+ '... call foo() on an instance metaclass object' );
+
+ ok( My::Class2->meta()->constructor_class()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s constructor class} );
+ ok( My::Class2->meta()->constructor_class()->can('foo'),
+ '... constructor class has a foo method' );
+
+ ok( My::Class2->meta()->destructor_class()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s destructor class} );
+ ok( My::Class2->meta()->destructor_class()->can('foo'),
+ '... destructor class has a foo method' );
+}
+
+
+{
+ package My::Meta;
+
+ use Moose::Exporter;
+ Moose::Exporter->setup_import_methods( also => 'Moose' );
+
+ sub init_meta {
+ shift;
+ my %p = @_;
+
+ Moose->init_meta( %p, metaclass => 'My::Meta::Class' );
+ }
+}
+
+{
+ package My::Class3;
+
+ My::Meta->import();
+}
+
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class3',
+ metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class3->meta()->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class3->meta()' );
+ is( My::Class3->meta()->foo(), 10,
+ '... and call foo() on that meta object' );
+ ok( ( grep { $_ eq 'My::Meta::Class' } My::Class3->meta()->meta()->superclasses() ),
+ 'apply_metaclass_roles() does not interfere with metaclass set via Moose->init_meta()' );
+}
+
+{
+ package Role::Bar;
+ use Moose::Role;
+ has 'bar' => ( is => 'ro', default => 200 );
+}
+
+{
+ package My::Class4;
+ use Moose;
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class4',
+ metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class4->meta()->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class4->meta()' );
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class4',
+ metaclass_roles => ['Role::Bar'],
+ );
+
+ ok( My::Class4->meta()->meta()->does_role('Role::Bar'),
+ 'apply Role::Bar to My::Class4->meta()' );
+ ok( My::Class4->meta()->meta()->does_role('Role::Foo'),
+ '... and My::Class4->meta() still does Role::Foo' );
+}
+
+{
+ package My::Class5;
+ use Moose;
+
+ extends 'My::Class';
+}
+
+{
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ q{My::Class5->meta()'s does Role::Foo because it extends My::Class} );
+ ok( My::Class->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{My::Class5->meta()'s attribute metaclass also does Role::Foo} );
+ ok( My::Class->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{My::Class5->meta()'s method metaclass also does Role::Foo} );
+ ok( My::Class->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{My::Class5->meta()'s instance metaclass also does Role::Foo} );
+ ok( My::Class->meta()->constructor_class()->meta()->does_role('Role::Foo'),
+ q{My::Class5->meta()'s constructor class also does Role::Foo} );
+ ok( My::Class->meta()->destructor_class()->meta()->does_role('Role::Foo'),
+ q{My::Class->meta()'s destructor class also does Role::Foo} );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class5',
+ metaclass_roles => ['Role::Bar'],
+ );
+
+ ok( My::Class5->meta()->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar My::Class5->meta()} );
+ ok( My::Class5->meta()->meta()->does_role('Role::Foo'),
+ q{... and My::Class5->meta() still does Role::Foo} );
+}
+
+SKIP:
+{
+ skip
+ 'These tests will fail until Moose::Meta::Class->_fix_metaclass_incompatibility is much smarter.',
+ 2;
+{
+ package My::Class6;
+ use Moose;
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class6',
+ metaclass_roles => ['Role::Bar'],
+ );
+
+ extends 'My::Class';
+}
+
+{
+ ok( My::Class6->meta()->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar My::Class6->meta() before extends} );
+ ok( My::Class6->meta()->meta()->does_role('Role::Foo'),
+ q{... and My::Class6->meta() does Role::Foo because it extends My::Class} );
+}
+}
+
+# This is the hack needed to work around the
+# _fix_metaclass_incompatibility problem. You must call extends()
+# (which in turn calls _fix_metaclass_imcompatibility) _before_ you
+# apply more extensions in the subclass.
+{
+ package My::Class7;
+ use Moose;
+
+ # In real usage this would go in a BEGIN block so it happened
+ # before apply_metaclass_roles was called by an extension.
+ extends 'My::Class';
+
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class7',
+ metaclass_roles => ['Role::Bar'],
+ );
+}
+
+{
+ ok( My::Class7->meta()->meta()->does_role('Role::Bar'),
+ q{apply Role::Bar My::Class7->meta() before extends} );
+ ok( My::Class7->meta()->meta()->does_role('Role::Foo'),
+ q{... and My::Class7->meta() does Role::Foo because it extends My::Class} );
+}
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More tests => 8;
+
+use Moose::Util::MetaRole;
+
+BEGIN
+{
+ package My::Meta::Class;
+ use Moose;
+ extends 'Moose::Meta::Class';
+}
+
+BEGIN
+{
+ package My::Meta::Attribute;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
+}
+
+BEGIN
+{
+ package My::Meta::Method;
+ use Moose;
+ extends 'Moose::Meta::Method';
+}
+
+BEGIN
+{
+ package My::Meta::Instance;
+ use Moose;
+ extends 'Moose::Meta::Instance';
+}
+
+BEGIN
+{
+ package Role::Foo;
+ use Moose::Role;
+ has 'foo' => ( is => 'ro', default => 10 );
+}
+
+{
+ package My::Class;
+
+ use metaclass 'My::Meta::Class';
+ use Moose;
+}
+
+{
+ package My::Class2;
+
+ use metaclass 'My::Meta::Class' => (
+ attribute_metaclass => 'My::Meta::Attribute',
+ method_metaclass => 'My::Meta::Method',
+ instance_metaclass => 'My::Meta::Instance',
+ );
+
+ use Moose;
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class',
+ metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class->meta()->meta()->does_role('Role::Foo'),
+ 'apply Role::Foo to My::Class->meta()' );
+ has_superclass( My::Class->meta(), 'My::Meta::Class',
+ 'apply_metaclass_roles works with metaclass.pm' );
+}
+
+{
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => 'My::Class2',
+ attribute_metaclass_roles => ['Role::Foo'],
+ method_metaclass_roles => ['Role::Foo'],
+ instance_metaclass_roles => ['Role::Foo'],
+ );
+
+ ok( My::Class2->meta()->attribute_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s attribute metaclass} );
+ has_superclass( My::Class2->meta()->attribute_metaclass(), 'My::Meta::Attribute',
+ '... and this does not interfere with attribute metaclass set via metaclass.pm' );
+ ok( My::Class2->meta()->method_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s method metaclass} );
+ has_superclass( My::Class2->meta()->method_metaclass(), 'My::Meta::Method',
+ '... and this does not interfere with method metaclass set via metaclass.pm' );
+ ok( My::Class2->meta()->instance_metaclass()->meta()->does_role('Role::Foo'),
+ q{apply Role::Foo to My::Class2->meta()'s instance metaclass} );
+ has_superclass( My::Class2->meta()->instance_metaclass(), 'My::Meta::Instance',
+ '... and this does not interfere with instance metaclass set via metaclass.pm' );
+}
+
+# like isa_ok but works with a class name, not just refs
+sub has_superclass {
+ my $thing = shift;
+ my $parent = shift;
+ my $desc = shift;
+
+ my %supers = map { $_ => 1 } $thing->meta()->superclasses();
+
+ local $Test::Builder::Level = $Test::Builder::Level + 1;
+
+ ok( $supers{$parent}, $desc );
+}
projects / gitmo/Moose.git / commitdiff