From: Dave Rolsky Date: Tue, 12 Aug 2008 16:02:09 +0000 (+0000) Subject: Reimplemented metaclass traits with Moose::Exporter. This X-Git-Tag: 0_55_01~41 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=5b5187e001776a5880742a5a78742c71c87fec16;p=gitmo%2FMoose.git Reimplemented metaclass traits with Moose::Exporter. This implementation also allows for traits on the role metaclass, but that will not be documented yet. --- diff --git a/MANIFEST b/MANIFEST index 651cdbf..dc521da 100644 --- a/MANIFEST +++ b/MANIFEST @@ -47,6 +47,7 @@ lib/Moose/Meta/Role/Application.pm 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 @@ -184,6 +185,7 @@ t/050_metaclasses/004_moose_for_meta.t 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 diff --git a/lib/Moose/Exporter.pm b/lib/Moose/Exporter.pm index 4dc0c21..eecb2f7 100644 --- a/lib/Moose/Exporter.pm +++ b/lib/Moose/Exporter.pm @@ -3,8 +3,9 @@ package Moose::Exporter; 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; @@ -160,6 +161,16 @@ sub _make_sub_exporter_params { 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. @@ -183,16 +194,63 @@ sub _make_sub_exporter_params { 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 diff --git a/lib/Moose/Meta/Role.pm b/lib/Moose/Meta/Role.pm index 82c7972..d69e368 100644 --- a/lib/Moose/Meta/Role.pm +++ b/lib/Moose/Meta/Role.pm @@ -403,6 +403,16 @@ sub apply { } } +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) = @_; @@ -573,6 +583,8 @@ probably not that much really). =item B +=item B + =item B =back diff --git a/lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm b/lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm new file mode 100644 index 0000000..a7f41b5 --- /dev/null +++ b/lib/Moose/Meta/Role/Application/ToMetaclassInstance.pm @@ -0,0 +1,92 @@ +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 + +=item B + +=item B + +=item B + +=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 Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006-2008 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut + diff --git a/lib/Moose/Util.pm b/lib/Moose/Util.pm index 3546138..db59d2f 100644 --- a/lib/Moose/Util.pm +++ b/lib/Moose/Util.pm @@ -71,33 +71,38 @@ sub search_class_by_role { 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 ... @@ -223,6 +228,13 @@ actually used internally by both L and L, and the C<@roles> will be pre-processed through L to allow for the additional arguments to be passed. +=item B + +This function works just like C, 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 Returns the values of the C<$instance>'s fields keyed by the attribute names. diff --git a/t/050_metaclasses/013_metaclass_traits.t b/t/050_metaclasses/013_metaclass_traits.t new file mode 100644 index 0000000..f6519f3 --- /dev/null +++ b/t/050_metaclasses/013_metaclass_traits.t @@ -0,0 +1,153 @@ +#!/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' );