From: gfx Date: Tue, 17 Nov 2009 07:21:10 +0000 (+0900) Subject: Add Mouse::Util::MetaRole X-Git-Tag: 0.40_07~9 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=f87debb99f7c14e24071098c395fbe7331894d49 Add Mouse::Util::MetaRole --- diff --git a/lib/Mouse/Meta/Module.pm b/lib/Mouse/Meta/Module.pm index b9281a8..bc74808 100755 --- a/lib/Mouse/Meta/Module.pm +++ b/lib/Mouse/Meta/Module.pm @@ -32,6 +32,8 @@ sub initialize { sub reinitialize { my($class, $package_name, @args) = @_; + $package_name = $package_name->name if ref $package_name; + ($package_name && !ref($package_name)) || $class->throw_error("You must pass a package name and it cannot be blessed"); diff --git a/lib/Mouse/Util/MetaRole.pm b/lib/Mouse/Util/MetaRole.pm new file mode 100644 index 0000000..fe68cbe --- /dev/null +++ b/lib/Mouse/Util/MetaRole.pm @@ -0,0 +1,200 @@ +package Mouse::Util::MetaRole; +use Mouse::Util; # enables strict and warnings + +our @Classes = qw(constructor_class destructor_class); + +sub apply_metaclass_roles { + my %options = @_; + + my $for = Scalar::Util::blessed($options{for_class}) + ? $options{for_class} + : Mouse::Util::class_of($options{for_class}); + + my %old_classes = map { $for->can($_) ? ($_ => $for->$_) : () } + @Classes; + + my $meta = _make_new_metaclass( $for, \%options ); + + for my $c ( grep { $meta->can($_) } @Classes ) { + if ( $options{ $c . '_roles' } ) { + my $class = _make_new_class( + $meta->$c(), + $options{ $c . '_roles' } + ); + + $meta->$c($class); + } + elsif($meta->$c ne $old_classes{$c}){ + $meta->$c( $old_classes{$c} ); + } + } + + return $meta; +} + +sub apply_base_class_roles { + my %options = @_; + + my $for = $options{for_class}; + + my $meta = Mouse::Util::class_of($for); + + my $new_base = _make_new_class( + $for, + $options{roles}, + [ $meta->superclasses() ], + ); + + $meta->superclasses($new_base) + if $new_base ne $meta->name(); + return; +} + + +my @Metaclasses = qw( + metaclass + attribute_metaclass + method_metaclass +); + +sub _make_new_metaclass { + my($for, $options) = @_; + + return $for + if !grep { exists $options->{ $_ . '_roles' } } @Metaclasses; + + my $new_metaclass + = _make_new_class( ref $for, $options->{metaclass_roles} ); + + # This could get called for a Mouse::Meta::Role as well as a Mouse::Meta::Class + my %classes = map { + $_ => _make_new_class( $for->$_(), $options->{ $_ . '_roles' } ) + } grep { $for->can($_) } @Metaclasses; + + return $new_metaclass->reinitialize( $for, %classes ); +} + + +sub _make_new_class { + my($existing_class, $roles, $superclasses) = @_; + + return $existing_class if !$roles; + + my $meta = Mouse::Meta::Class->initialize($existing_class); + + return $existing_class + if !grep { !ref($_) && !$meta->does_role($_) } @{$roles}; + + return Mouse::Meta::Class->create_anon_class( + superclasses => $superclasses ? $superclasses : [$existing_class], + roles => $roles, + cache => 1, + )->name(); +} + +1; + +__END__ + +=head1 NAME + +Mouse::Util::MetaRole - Apply roles to any metaclass, as well as the object base class + +=head1 SYNOPSIS + + package MyApp::Mouse; + + use Mouse (); + use Mouse::Exporter; + use Mouse::Util::MetaRole; + + use MyApp::Role::Meta::Class; + use MyApp::Role::Meta::Method::Constructor; + use MyApp::Role::Object; + + Mouse::Exporter->setup_import_methods( also => 'Mouse' ); + + sub init_meta { + shift; + my %options = @_; + + Mouse->init_meta(%options); + + Mouse::Util::MetaRole::apply_metaclass_roles( + for_class => $options{for_class}, + metaclass_roles => ['MyApp::Role::Meta::Class'], + constructor_class_roles => ['MyApp::Role::Meta::Method::Constructor'], + ); + + Mouse::Util::MetaRole::apply_base_class_roles( + for_class => $options{for_class}, + roles => ['MyApp::Role::Object'], + ); + + return $options{for_class}->meta(); + } + +=head1 DESCRIPTION + +This utility module is designed to help authors of Mouse extensions +write extensions that are able to cooperate with other Mouse +extensions. To do this, you must write your extensions as roles, which +can then be dynamically applied 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. 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, which can generate the appropriate C +method for you, and make sure it is 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 * 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 SEE ASLSO + +L + +=cut