use base qw(Mouse::Meta::Module);
+sub method_metaclass(){ 'Mouse::Meta::Method' } # required for get_method()
sub _new {
my($class, %args) = @_;
sub make_mutable { not_supported }
-sub is_immutable { $_[0]->{is_immutable} }
-
-sub attribute_metaclass { "Mouse::Meta::Class" }
+sub is_immutable { $_[0]->{is_immutable} }
+sub is_mutable { !$_[0]->{is_immutable} }
sub _install_modifier {
my ( $self, $into, $type, $name, $code ) = @_;
# replace this method itself :)
{
- no strict 'refs';
no warnings 'redefine';
- *{__PACKAGE__ . '::_install_modifier'} = sub {
+ *_install_modifier = sub {
my ( $self, $into, $type, $name, $code ) = @_;
$modifier->(
$into,
$name,
$code
);
+ $self->{methods}{$name}++; # register it to the method map
+ return;
};
}
sub add_override_method_modifier {
my ($self, $name, $code) = @_;
- my $pkg = $self->name;
- my $method = "${pkg}::${name}";
+ my $package = $self->name;
- # Class::Method::Modifiers won't do this for us, so do it ourselves
+ my $body = $package->can($name)
+ or $self->throw_error("You cannot override '$name' because it has no super method");
- my $body = $pkg->can($name)
- or $self->throw_error("You cannot override '$method' because it has no super method");
-
- no strict 'refs';
- *$method = sub { $code->($pkg, $body, @_) };
+ $self->add_method($name => sub { $code->($package, $body, @_) });
}
sub does_role {
|| $self->throw_error("You must supply a role name to look for");
for my $class ($self->linearized_isa) {
- my $meta = Mouse::class_of($class);
+ my $meta = Mouse::Meta::Module::class_of($class);
next unless $meta && $meta->can('roles');
for my $role (@{ $meta->roles }) {
+
return 1 if $role->does_role($role_name);
}
}
|| $class->throw_error("You must pass a HASH ref of methods")
if exists $options{methods};
- do {
+ (ref $options{roles} eq 'ARRAY')
+ || $class->throw_error("You must pass an ARRAY ref of roles")
+ if exists $options{roles};
+
+ {
( defined $package_name && $package_name )
|| $class->throw_error("You must pass a package name");
- my $code = "package $package_name;";
- $code .= "\$$package_name\:\:VERSION = '" . $options{version} . "';"
- if exists $options{version};
- $code .= "\$$package_name\:\:AUTHORITY = '" . $options{authority} . "';"
- if exists $options{authority};
-
- eval $code;
- $class->throw_error("creation of $package_name failed : $@") if $@;
- };
+ no strict 'refs';
+ ${ $package_name . '::VERSION' } = $options{version} if exists $options{version};
+ ${ $package_name . '::AUTHORITY' } = $options{authority} if exists $options{authority};
+ }
my %initialize_options = %options;
delete @initialize_options{qw(
superclasses
attributes
methods
+ roles
version
authority
)};
$meta->add_method($method_name, $options{methods}->{$method_name});
}
}
+ if (exists $options{roles}){
+ Mouse::Util::apply_all_roles($package_name, @{$options{roles}});
+ }
return $meta;
}
{
my $ANON_CLASS_SERIAL = 0;
my $ANON_CLASS_PREFIX = 'Mouse::Meta::Class::__ANON__::SERIAL::';
+
+ my %IMMORTAL_ANON_CLASSES;
sub create_anon_class {
my ( $class, %options ) = @_;
+
+ my $cache = $options{cache};
+ my $cache_key;
+
+ if($cache){ # anonymous but not mortal
+ # something like Super::Class|Super::Class::2=Role|Role::1\r
+ $cache_key = join '=' => (\r
+ join('|', @{$options{superclasses} || []}),\r
+ join('|', sort @{$options{roles} || []}),\r
+ );
+ return $IMMORTAL_ANON_CLASSES{$cache_key} if exists $IMMORTAL_ANON_CLASSES{$cache_key};
+ }
my $package_name = $ANON_CLASS_PREFIX . ++$ANON_CLASS_SERIAL;
- return $class->create( $package_name, %options );
+ my $meta = $class->create( $package_name, anon_class_id => $ANON_CLASS_SERIAL, %options );
+
+ if($cache){
+ $IMMORTAL_ANON_CLASSES{$cache_key} = $meta;
+ }
+ else{
+ Mouse::Meta::Module::weaken_metaclass($package_name);
+ }
+ return $meta;
+ }
+
+ sub is_anon_class{
+ return exists $_[0]->{anon_class_id};
}
+
+
+ sub DESTROY{
+ my($self) = @_;
+
+ my $serial_id = $self->{anon_class_id};
+
+ return if !$serial_id;
+
+ my $stash = $self->namespace;
+
+ @{$self->{sperclasses}} = ();
+ %{$stash} = ();
+ Mouse::Meta::Module::remove_metaclass_by_name($self->name);
+
+ no strict 'refs';
+ delete ${$ANON_CLASS_PREFIX}{ $serial_id . '::' };
+
+ return;
+ }
+
}
1;