lib/Moose/Meta/Role/Application/RoleSummation.pm
lib/Moose/Meta/Role/Application/ToClass.pm
lib/Moose/Meta/Role/Application/ToInstance.pm
+lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm
lib/Moose/Meta/Role/Application/ToRole.pm
lib/Moose/Meta/Role/Composite.pm
lib/Moose/Meta/Role/Method.pm
t/050_metaclasses/010_extending_and_embedding_back_compat.t
t/050_metaclasses/011_init_meta.t
t/050_metaclasses/012_moose_exporter.t
+t/050_metaclasses/013_metaclass_traits.t
t/060_compat/001_module_refresh_compat.t
t/060_compat/002_moose_respects_base.t
t/060_compat/003_foreign_inheritence.t
use strict;
use warnings;
+use Carp qw( confess );
use Class::MOP;
-use List::MoreUtils qw( uniq );
+use List::MoreUtils qw( first_index uniq );
use Sub::Exporter;
my $export_to_main = shift;
return sub {
+ # I think we could use Sub::Exporter's collector feature
+ # to do this, but that would be rather gross, since that
+ # feature isn't really designed to return a value to the
+ # caller of the exporter sub.
+ #
+ # Also, this makes sure we preserve backwards compat for
+ # _get_caller, so it always sees the arguments in the
+ # expected order.
+ my $traits;
+ ($traits, @_) = Moose::Exporter::_strip_traits(@_);
# It's important to leave @_ as-is for the benefit of
# Sub::Exporter.
return;
}
- for my $c (grep { $_->can('init_meta') } $class, @{$exports_from} ) {
+ my $did_init_meta;
+ for my $c ( grep { $_->can('init_meta') } $class, @{$exports_from} ) {
$c->init_meta( for_class => $CALLER );
+ $did_init_meta = 1;
}
+ _apply_meta_traits( $CALLER, $traits )
+ if $did_init_meta;
+
goto $exporter;
};
}
}
+sub _strip_traits {
+ my $idx = first_index { $_ eq '-traits' } @_;
+
+ return ( undef, @_ ) unless $idx >= 0 && $#_ >= $idx + 1;
+
+ my $traits = $_[ $idx + 1 ];
+
+ splice @_, $idx, 2;
+
+ return ( $traits, @_ );
+}
+
+sub _apply_meta_traits {
+ my ( $class, $traits ) = @_;
+
+ return
+ unless $traits && @$traits;
+
+ my $meta = $class->meta();
+
+ my $type = ( split /::/, ref $meta )[-1]
+ or confess
+ '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;
+
+ return unless @traits;
+
+ Moose::Util::apply_all_roles_with_method( $meta,
+ 'apply_to_metaclass_instance', \@traits );
+}
+
sub _get_caller {
# 1 extra level because it's called by import so there's a layer
# of indirection
}
}
+sub apply_to_metaclass_instance {
+ my ($self, $meta, @args) = @_;
+
+ $meta->isa('Moose::Meta::Class') || $meta->isa('Moose::Meta::Role')
+ || confess "You must pass in a Moose::Meta::Class or Moose::Meta::Role instance";
+
+ require Moose::Meta::Role::Application::ToMetaclassInstance;
+ return Moose::Meta::Role::Application::ToMetaclassInstance->new(@args)->apply($self, $meta);
+}
+
sub combine {
my ($class, @role_specs) = @_;
=item B<apply>
+=item B<apply_to_metaclass_instance>
+
=item B<combine>
=back
--- /dev/null
+package Moose::Meta::Role::Application::ToMetaclassInstance;
+
+use strict;
+use warnings;
+use metaclass;
+
+use Scalar::Util 'blessed';
+
+our $VERSION = '0.55';
+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
+
sub apply_all_roles {
my $applicant = shift;
-
- confess "Must specify at least one role to apply to $applicant" unless @_;
-
- my $roles = Data::OptList::mkopt([ @_ ]);
-
- #use Data::Dumper;
- #warn Dumper $roles;
-
- my $meta = (blessed $applicant ? $applicant : find_meta($applicant));
-
+
+ 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;
+
+ my $roles = Data::OptList::mkopt($role_list);
+
+ my $meta = ( blessed $applicant ? $applicant : find_meta($applicant) );
+
foreach my $role_spec (@$roles) {
- Class::MOP::load_class($role_spec->[0]);
+ Class::MOP::load_class( $role_spec->[0] );
}
-
- ($_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role'))
- || confess "You can only consume roles, " . $_->[0] . " is not a Moose role"
- foreach @$roles;
- if (scalar @$roles == 1) {
- my ($role, $params) = @{$roles->[0]};
- $role->meta->apply($meta, (defined $params ? %$params : ()));
+ ( $_->[0]->can('meta') && $_->[0]->meta->isa('Moose::Meta::Role') )
+ || confess "You can only consume roles, "
+ . $_->[0]
+ . " is not a Moose role"
+ foreach @$roles;
+
+ if ( scalar @$roles == 1 ) {
+ my ( $role, $params ) = @{ $roles->[0] };
+ $role->meta->$apply_method( $meta,
+ ( defined $params ? %$params : () ) );
}
else {
- Moose::Meta::Role->combine(
- @$roles
- )->apply($meta);
- }
+ Moose::Meta::Role->combine( @$roles )->$apply_method($meta);
+ }
}
# instance deconstruction ...
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
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+{
+ package My::SimpleTrait;
+
+ use Moose::Role;
+
+ sub simple { return 5 }
+}
+
+{
+ package Foo;
+
+ use Moose -traits => [ 'My::SimpleTrait' ];
+}
+
+can_ok( Foo->meta(), 'simple' );
+is( Foo->meta()->simple(), 5,
+ 'Foo->meta()->simple() returns expected value' );
+
+{
+ package My::SimpleTrait2;
+
+ use Moose::Role;
+
+ # This needs to happen at compile time so it happens before we
+ # apply traits to Bar
+ BEGIN {
+ has 'attr' =>
+ ( is => 'ro',
+ default => 'something',
+ );
+ }
+
+ sub simple { return 5 }
+}
+
+{
+ package Bar;
+
+ use Moose -traits => [ 'My::SimpleTrait2' ];
+}
+
+can_ok( Bar->meta(), 'simple' );
+is( Bar->meta()->simple(), 5,
+ 'Bar->meta()->simple() returns expected value' );
+can_ok( Bar->meta(), 'attr' );
+is( Bar->meta()->attr(), 'something',
+ 'Bar->meta()->attr() returns expected value' );
+
+{
+ package My::SimpleTrait3;
+
+ use Moose::Role;
+
+ BEGIN {
+ has 'attr2' =>
+ ( is => 'ro',
+ default => 'something',
+ );
+ }
+
+ sub simple2 { return 55 }
+}
+
+{
+ package Baz;
+
+ use Moose -traits => [ 'My::SimpleTrait2', 'My::SimpleTrait3' ];
+}
+
+can_ok( Baz->meta(), 'simple' );
+is( Baz->meta()->simple(), 5,
+ 'Baz->meta()->simple() returns expected value' );
+can_ok( Baz->meta(), 'attr' );
+is( Baz->meta()->attr(), 'something',
+ 'Baz->meta()->attr() returns expected value' );
+can_ok( Baz->meta(), 'simple2' );
+is( Baz->meta()->simple2(), 55,
+ 'Baz->meta()->simple2() returns expected value' );
+can_ok( Baz->meta(), 'attr2' );
+is( Baz->meta()->attr2(), 'something',
+ 'Baz->meta()->attr2() returns expected value' );
+
+{
+ package My::Trait::AlwaysRO;
+
+ use Moose::Role;
+
+ around '_process_new_attribute', '_process_inherited_attribute' =>
+ sub {
+ my $orig = shift;
+ my ( $self, $name, %args ) = @_;
+
+ $args{is} = 'ro';
+
+ return $self->$orig( $name, %args );
+ };
+}
+
+{
+ package Quux;
+
+ use Moose -traits => [ 'My::Trait::AlwaysRO' ];
+
+ has 'size' =>
+ ( is => 'rw',
+ isa => 'Int',
+ );
+}
+
+ok( Quux->meta()->has_attribute('size'),
+ 'Quux has size attribute' );
+ok( ! Quux->meta()->get_attribute('size')->writer(),
+ 'size attribute does not have a writer' );
+
+{
+ package My::Class::Whatever;
+
+ use Moose::Role;
+
+ sub whatever { 42 }
+
+ package Moose::Meta::Class::Custom::Trait::Whatever;
+
+ sub register_implementation {
+ return 'My::Class::Whatever';
+ }
+}
+
+{
+ package RanOutOfNames;
+
+ use Moose -traits => [ 'Whatever' ];
+}
+
+ok( RanOutOfNames->meta()->meta()->has_method('whatever'),
+ 'RanOutOfNames->meta() has whatever method' );
+
+{
+ package Role::Foo;
+
+ use Moose::Role -traits => [ 'My::SimpleTrait' ];
+}
+
+can_ok( Role::Foo->meta(), 'simple' );
+is( Role::Foo->meta()->simple(), 5,
+ 'Role::Foo->meta()->simple() returns expected value' );
projects / gitmo/Moose.git / commitdiff