# More or less copied from Moose::Meta::Class
sub initialize {
my $class = shift;
- my $pkg = shift;
-
- if (defined(my $meta = Class::MOP::get_metaclass_by_name($pkg))) {
- return $meta;
- }
-
- my %options = @_;
-
- my $meta = $class->SUPER::initialize(
- $pkg,
- 'attribute_metaclass' => 'Moose::Meta::Role::Attribute',
- %options,
- );
-
- Class::MOP::weaken_metaclass($pkg) if $options{weaken};
-
- return $meta;
+ my @args = @_;
+ unshift @args, 'package' if @args % 2;
+ my %opts = @args;
+ my $package = delete $opts{package};
+ return Class::MOP::get_metaclass_by_name($package)
+ || $class->SUPER::initialize($package,
+ 'attribute_metaclass' => 'Moose::Meta::Role::Attribute',
+ %opts,
+ );
}
sub reinitialize {
}
sub create {
- my ( $role, $package_name, %options ) = @_;
+ my $class = shift;
+ my @args = @_;
- $options{package} = $package_name;
+ unshift @args, 'package' if @args % 2 == 1;
+ my %options = @args;
(ref $options{attributes} eq 'HASH')
|| confess "You must pass a HASH ref of attributes"
|| confess "You must pass a HASH ref of methods"
if exists $options{methods};
- $options{meta_name} = 'meta'
- unless exists $options{meta_name};
-
- my (%initialize_options) = %options;
- delete @initialize_options{qw(
- package
- attributes
- methods
- meta_name
- version
- authority
- )};
-
- my $meta = $role->initialize( $package_name => %initialize_options );
+ my $package = delete $options{package};
+ my $attributes = delete $options{attributes};
+ my $methods = delete $options{methods};
+ my $meta_name = exists $options{meta_name}
+ ? delete $options{meta_name}
+ : 'meta';
- $meta->_instantiate_module( $options{version}, $options{authority} );
+ my $meta = $class->SUPER::create($package => %options);
- $meta->_add_meta_method($options{meta_name})
- if defined $options{meta_name};
+ $meta->_add_meta_method($meta_name)
+ if defined $meta_name;
- if (exists $options{attributes}) {
- foreach my $attribute_name (keys %{$options{attributes}}) {
- my $attr = $options{attributes}->{$attribute_name};
+ if (defined $attributes) {
+ foreach my $attribute_name (keys %{$attributes}) {
+ my $attr = $attributes->{$attribute_name};
$meta->add_attribute(
$attribute_name => blessed $attr ? $attr : %{$attr} );
}
}
- if (exists $options{methods}) {
- foreach my $method_name (keys %{$options{methods}}) {
- $meta->add_method($method_name, $options{methods}->{$method_name});
+ if (defined $methods) {
+ foreach my $method_name (keys %{$methods}) {
+ $meta->add_method($method_name, $methods->{$method_name});
}
}
return @consumers;
}
-# anonymous roles. most of it is copied straight out of Class::MOP::Class.
-# an intrepid hacker might find great riches if he unifies this code with that
-# code in Class::MOP::Module or Class::MOP::Package
-{
- # NOTE:
- # this should be sufficient, if you have a
- # use case where it is not, write a test and
- # I will change it.
- my $ANON_ROLE_SERIAL = 0;
+# XXX: something more intelligent here?
+sub _anon_package_prefix { 'Moose::Meta::Role::__ANON__::SERIAL::' }
- # NOTE:
- # we need a sufficiently annoying prefix
- # this should suffice for now, this is
- # used in a couple of places below, so
- # need to put it up here for now.
- my $ANON_ROLE_PREFIX = 'Moose::Meta::Role::__ANON__::SERIAL::';
-
- sub is_anon_role {
- my $self = shift;
- no warnings 'uninitialized';
- $self->name =~ /^$ANON_ROLE_PREFIX/;
- }
+sub create_anon_role { shift->create_anon(@_) }
+sub is_anon_role { shift->is_anon(@_) }
- sub create_anon_role {
- my ($role, %options) = @_;
- $options{weaken} = 1 unless exists $options{weaken};
- my $package_name = $ANON_ROLE_PREFIX . ++$ANON_ROLE_SERIAL;
- return $role->create($package_name, %options);
- }
-
- sub DESTROY {
- my $self = shift;
-
- return if in_global_destruction(); # it'll happen soon anyway and this just makes things more complicated
-
- $self->free_anon_role
- if $self->is_anon_role;
- }
-
- sub free_anon_role {
- my $self = shift;
- my $name = $self->name;
-
- my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
-
- # Moose does a weird thing where it replaces the metaclass for
- # class when fixing metaclass incompatibility. In that case,
- # we don't want to clean out the namespace now. We can detect
- # that because Moose will explicitly update the singleton
- # cache in Class::MOP.
- my $current_meta = Class::MOP::get_metaclass_by_name($self->name);
- return if $current_meta ne $self;
-
- no strict 'refs';
- @{$name . '::ISA'} = ();
- %{$name . '::'} = ();
- delete ${$first_fragments . '::'}{$last_fragment . '::'};
-
- Class::MOP::remove_metaclass_by_name($name);
- }
+sub _anon_cache_key {
+ my $class = shift;
+ my %options = @_;
+ # Makes something like Role|Role::1
+ return join '=' => (
+ join( '|', sort @{ $options{roles} || [] } ),
+ );
}
#####################################################################
=back
-=head2 Destruction
-
-=over 4
-
-=item B<< $metarole->free_anon_role >>
-
-This removes the metarole from the symbol table and L<Moose>'s own
-bookkeeping. This should probably only be called by L</DESTROY>.
-
=head1 BUGS
See L<Moose/BUGS> for details on reporting bugs.
projects / gitmo/Moose.git / blobdiff