use Carp 'confess';
use Scalar::Util 'blessed', 'reftype', 'weaken';
use Sub::Name 'subname';
-use Devel::GlobalDestruction 'in_global_destruction';
use Try::Tiny;
use List::MoreUtils 'all';
}
}
-## ANON classes
-
-{
- # 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_CLASS_SERIAL = 0;
-
- # 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_CLASS_PREFIX = 'Class::MOP::Class::__ANON__::SERIAL::';
-
- sub is_anon_class {
- my $self = shift;
- no warnings 'uninitialized';
- $self->name =~ /^$ANON_CLASS_PREFIX/o;
- }
-
- sub create_anon_class {
- my ($class, %options) = @_;
- $options{weaken} = 1 unless exists $options{weaken};
- my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
- return $class->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_class
- if $self->is_anon_class;
- }
-
- sub free_anon_class {
- my $self = shift;
- my $name = $self->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.
- no warnings 'uninitialized';
- my $current_meta = Class::MOP::get_metaclass_by_name($name);
- return if $current_meta ne $self;
-
- my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
-
- no strict 'refs';
- @{$name . '::ISA'} = ();
- %{$name . '::'} = ();
- delete ${$first_fragments . '::'}{$last_fragment . '::'};
-
- Class::MOP::remove_metaclass_by_name($name);
- }
-
-}
-
# creating classes with MOP ...
sub create {
- my ( $class, @args ) = @_;
+ my $class = shift;
+ my @args = @_;
unshift @args, 'package' if @args % 2 == 1;
-
- my (%options) = @args;
- my $package_name = $options{package};
+ my %options = @args;
(ref $options{superclasses} eq 'ARRAY')
|| confess "You must pass an ARRAY ref of superclasses"
if exists $options{superclasses};
-
+
(ref $options{attributes} eq 'ARRAY')
|| confess "You must pass an ARRAY ref of attributes"
- if exists $options{attributes};
-
+ if exists $options{attributes};
+
(ref $options{methods} eq 'HASH')
|| 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) = @args;
- delete @initialize_options{qw(
- package
- superclasses
- attributes
- methods
- meta_name
- version
- authority
- )};
- my $meta = $class->initialize( $package_name => %initialize_options );
-
- $meta->_instantiate_module( $options{version}, $options{authority} );
-
- $meta->_add_meta_method($options{meta_name})
- if defined $options{meta_name};
-
- $meta->superclasses(@{$options{superclasses}})
- if exists $options{superclasses};
+ if exists $options{methods};
+
+ my $package = delete $options{package};
+ my $superclasses = delete $options{superclasses};
+ my $attributes = delete $options{attributes};
+ my $methods = delete $options{methods};
+ my $meta_name = exists $options{meta_name}
+ ? delete $options{meta_name}
+ : 'meta';
+
+ my $meta = $class->SUPER::create($package => %options);
+
+ $meta->_add_meta_method($meta_name)
+ if defined $meta_name;
+
+ $meta->superclasses(@{$superclasses})
+ if defined $superclasses;
# NOTE:
# process attributes first, so that they can
# install accessors, but locally defined methods
# can then overwrite them. It is maybe a little odd, but
# I think this should be the order of things.
- if (exists $options{attributes}) {
- foreach my $attr (@{$options{attributes}}) {
+ if (defined $attributes) {
+ foreach my $attr (@{$attributes}) {
$meta->add_attribute($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 $meta;
}
+# XXX: something more intelligent here?
+sub _anon_package_prefix { 'Class::MOP::Class::__ANON__::SERIAL::' }
+
+sub create_anon_class { shift->create_anon(@_) }
+sub is_anon_class { shift->is_anon(@_) }
+
+sub _anon_cache_key {
+ my $class = shift;
+ my %options = @_;
+ # Makes something like Super::Class|Super::Class::2
+ return join '=' => (
+ join( '|', sort @{ $options{superclasses} || [] } ),
+ );
+}
+
# Instance Construction & Cloning
sub new_object {
=back
-=head2 Destruction
-
-=over 4
-
-=item B<< $metaclass->free_anon_class >>
-
-This removes the metaclass from the symbol table and L<Class::MOP>'s own
-bookkeeping. This should probably only be called by L</DESTROY>.
-
=cut
}
sub create {
- confess "The Class::MOP::Module->create method has been made a private object method.\n";
+ my $class = shift;
+ my @args = @_;
+
+ unshift @args, 'package' if @args % 2 == 1;
+ my %options = @args;
+
+ my $package = delete $options{package};
+ my $version = delete $options{version};
+ my $authority = delete $options{authority};
+
+ my $meta = $class->SUPER::create($package => %options);
+
+ $meta->_instantiate_module($version, $authority);
+
+ return $meta;
}
+sub _anon_package_prefix { 'Class::MOP::Module::__ANON__::SERIAL::' }
+sub _anon_cache_key { confess "Modules are not cacheable" }
+
+
sub _instantiate_module {
my($self, $version, $authority) = @_;
my $package_name = $self->name;
use strict;
use warnings;
-use Scalar::Util 'blessed', 'reftype';
+use Scalar::Util 'blessed', 'reftype', 'weaken';
use Carp 'confess';
+use Devel::GlobalDestruction 'in_global_destruction';
use Package::Stash;
use base 'Class::MOP::Object';
unshift @args, "package" if @args % 2;
my %options = @args;
- my $package_name = $options{package};
+ my $package_name = delete $options{package};
# we hand-construct the class
});
Class::MOP::store_metaclass_by_name($package_name, $meta);
+ Class::MOP::weaken_metaclass($package_name) if $options{weaken};
+
+
return $meta;
}
}
$class->initialize($package_name, %options); # call with first arg form for compat
}
+sub create {
+ my $class = shift;
+ my @args = @_;
+
+ return $class->initialize(@args);
+}
+
+## ANON packages
+
+{
+ # 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_SERIAL = 0;
+
+ my %ANON_PACKAGE_CACHE;
+
+ # 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.
+ sub _anon_package_prefix { 'Class::MOP::Package::__ANON__::SERIAL::' }
+
+ sub is_anon {
+ my $self = shift;
+ no warnings 'uninitialized';
+ my $prefix = $self->_anon_package_prefix;
+ $self->name =~ /^$prefix/;
+ }
+
+ sub create_anon {
+ my ($class, %options) = @_;
+
+ my $cache_ok = delete $options{cache};
+
+ my $cache_key = $class->_anon_cache_key(%options);
+
+ if ($cache_ok && defined $ANON_PACKAGE_CACHE{$cache_key}) {
+ return $ANON_PACKAGE_CACHE{$cache_key};
+ }
+
+ $options{weaken} = !$cache_ok unless exists $options{weaken};
+
+ my $package_name = $class->_anon_package_prefix . ++$ANON_SERIAL;
+
+ my $meta = $class->create($package_name, %options);
+
+ if ($cache_ok) {
+ $ANON_PACKAGE_CACHE{$cache_key} = $meta;
+ weaken($ANON_PACKAGE_CACHE{$cache_key});
+ }
+
+ return $meta;
+ }
+
+ sub _anon_cache_key { confess "Packages are not cacheable" }
+
+ 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
+ if $self->is_anon;
+ }
+
+ sub _free_anon {
+ my $self = shift;
+ my $name = $self->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.
+ no warnings 'uninitialized';
+ my $current_meta = Class::MOP::get_metaclass_by_name($name);
+ return if $current_meta ne $self;
+
+ my ($first_fragments, $last_fragment) = ($name =~ /^(.*)::(.*)$/);
+
+ no strict 'refs';
+ @{$name . '::ISA'} = ();
+ %{$name . '::'} = ();
+ delete ${$first_fragments . '::'}{$last_fragment . '::'};
+
+ Class::MOP::remove_metaclass_by_name($name);
+ }
+
+}
+
sub _new {
my $class = shift;
use Data::OptList;
use List::Util qw( first );
use List::MoreUtils qw( any all uniq first_index );
-use Scalar::Util 'weaken', 'blessed';
+use Scalar::Util 'blessed';
use Moose::Meta::Method::Overridden;
use Moose::Meta::Method::Augmented;
sub initialize {
my $class = shift;
- my $pkg = shift;
- return Class::MOP::get_metaclass_by_name($pkg)
- || $class->SUPER::initialize($pkg,
+ 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::Attribute',
'method_metaclass' => 'Moose::Meta::Method',
'instance_metaclass' => 'Moose::Meta::Instance',
- @_
+ %opts,
);
}
sub create {
- my ($class, $package_name, %options) = @_;
+ my $class = shift;
+ my @args = @_;
+
+ unshift @args, 'package' if @args % 2 == 1;
+ my %options = @args;
(ref $options{roles} eq 'ARRAY')
|| $class->throw_error("You must pass an ARRAY ref of roles", data => $options{roles})
if exists $options{roles};
- my $roles = delete $options{roles};
- my $new_meta = $class->SUPER::create($package_name, %options);
+ my $package = delete $options{package};
+ my $roles = delete $options{roles};
+
+ my $new_meta = $class->SUPER::create($package, %options);
if ($roles) {
Moose::Util::apply_all_roles( $new_meta, @$roles );
return $new_meta;
}
-my %ANON_CLASSES;
-
-sub create_anon_class {
- my ($self, %options) = @_;
-
- my $cache_ok = delete $options{cache};
-
- my $cache_key
- = _anon_cache_key( $options{superclasses}, $options{roles} );
-
- if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
- return $ANON_CLASSES{$cache_key};
- }
-
- $options{weaken} = !$cache_ok
- unless exists $options{weaken};
-
- my $new_class = $self->SUPER::create_anon_class(%options);
-
- if ($cache_ok) {
- $ANON_CLASSES{$cache_key} = $new_class;
- weaken($ANON_CLASSES{$cache_key});
- }
-
- return $new_class;
-}
-
sub _meta_method_class { 'Moose::Meta::Method::Meta' }
+sub _anon_package_prefix { 'Moose::Meta::Class::__ANON__::SERIAL::' }
+
sub _anon_cache_key {
+ my $class = shift;
+ my %options = @_;
# Makes something like Super::Class|Super::Class::2=Role|Role::1
return join '=' => (
- join( '|', @{ $_[0] || [] } ),
- join( '|', sort @{ $_[1] || [] } ),
+ join( '|', @{ $options{superclasses} || [] } ),
+ join( '|', sort @{ $options{roles} || [] } ),
);
}
my $meta = blessed $pkg ? $pkg : Class::MOP::class_of($pkg);
- my $cache_key;
-
my %existing_classes;
if ($meta) {
%existing_classes = map { $_ => $meta->$_() } qw(
destructor_class
error_class
);
-
- $cache_key = _anon_cache_key(
- [ $meta->superclasses ],
- [ map { $_->name } @{ $meta->roles } ],
- ) if $meta->is_anon_class;
}
- my $new_meta = $self->SUPER::reinitialize(
+ return $self->SUPER::reinitialize(
$pkg,
%existing_classes,
@_,
);
-
- return $new_meta unless defined $cache_key;
-
- my $new_cache_key = _anon_cache_key(
- [ $meta->superclasses ],
- [ map { $_->name } @{ $meta->roles } ],
- );
-
- delete $ANON_CLASSES{$cache_key};
- $ANON_CLASSES{$new_cache_key} = $new_meta;
- weaken($ANON_CLASSES{$new_cache_key});
-
- return $new_meta;
}
sub add_role {
# 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.
my @class_mop_package_methods = qw(
_new
- initialize reinitialize
+ initialize reinitialize create create_anon is_anon
+ _free_anon _anon_cache_key _anon_package_prefix
name
namespace
_package_stash
get_method_map
+
+ DESTROY
);
my @class_mop_module_methods = qw(
_instantiate_module
version authority identifier create
+
+ _anon_cache_key _anon_package_prefix
);
my @class_mop_class_methods = qw(
initialize reinitialize create
- create_anon_class is_anon_class free_anon_class
+ create_anon_class is_anon_class
+ _anon_cache_key _anon_package_prefix
instance_metaclass get_meta_instance
_inline_create_instance
_immutable_metaclass
immutable_trait immutable_options
constructor_name constructor_class destructor_class
-
- DESTROY
);
# check the class ...
projects / gitmo/Moose.git / commitdiff