use Moose::Meta::Class::Immutable::Trait;
use Moose::Meta::Method::Constructor;
use Moose::Meta::Method::Destructor;
-use Moose::Meta::Method::Does;
use base 'Class::MOP::Class';
default => 'Moose::Meta::Method::Destructor',
));
-__PACKAGE__->meta->add_attribute('does_class' => (
- accessor => 'does_class',
- default => 'Moose::Meta::Method::Does',
-));
-
__PACKAGE__->meta->add_attribute('error_class' => (
accessor => 'error_class',
default => 'Moose::Error::Default',
instance_metaclass
constructor_class
destructor_class
- does_class
error_class
);
$self->SUPER::_immutable_options(
inline_destructor => 1,
- inline_does => 1,
# Moose always does this when an attribute is created
inline_accessors => 0,
);
}
-sub _install_inlined_code {
- my ( $self, %args ) = @_;
-
- $self->SUPER::_install_inlined_code(%args);
-
- $self->_inline_does(%args) if $args{inline_does};
-}
-
-sub _inline_does {
- my ( $self, %args ) = @_;
-
- if ( $self->has_method('does') ) {
- my $class = $self->name;
- warn "Not inlining a does method for $class since it defines"
- . " its own does().\n";
- return;
- }
-
- my $does = $self->does_class->new(
- options => \%args,
- metaclass => $self,
- is_inline => 1,
- package_name => $self->name,
- );
-
- if ( $args{replace_does} or $does->can_be_inlined ) {
- $self->add_method( 'does' => $does );
- $self->_add_inlined_method($does);
- }
-}
-
## -------------------------------------------------
our $error_level;
Since Moose always inlines attributes, it sets the C<inline_accessors> option
to false.
-Because Moose attempts to inline C<does> when possible, this method accepts
-C<inline_does> and C<replace_does> options. The default is to inline the does
-method, but an existing does method in a parent will not be replaced.
-
=item B<< $metaclass->new_object(%params) >>
This overrides the parent's method in order to add support for
=item B<< $metaclass->destructor_class($class_name) >>
-=item B<< $metaclass->does_class($class_name) >>
-
These are the names of classes used when making a class immutable. These
-default to L<Moose::Meta::Method::Constructor>,
-L<Moose::Meta::Method::Destructor>, and L<Moose::Meta::Method::Does>
-respectively. These accessors are read-write, so you can use them to change
-the class name.
+default to L<Moose::Meta::Method::Constructor> and
+L<Moose::Meta::Method::Destructor> respectively. These accessors are
+read-write, so you can use them to change the class name.
=item B<< $metaclass->error_class($class_name) >>
use warnings;
use Class::MOP;
+use Scalar::Util qw( blessed );
our $VERSION = '1.12';
$VERSION = eval $VERSION;
@{ $self->{__immutable}{calculate_all_roles_with_inheritance} ||= [ $self->$orig ] };
}
+sub does_role {
+ shift;
+ my $self = shift;
+ my $role = shift;
+
+ (defined $role)
+ || $self->throw_error("You must supply a role name to look for");
+
+ $self->{__immutable}{does_role} ||= { map { $_->name => 1 } $self->calculate_all_roles_with_inheritance };
+
+ my $name = blessed $role ? $role->name : $role;
+
+ return $self->{__immutable}{does_role}{$name};
+}
+
1;
__END__
+++ /dev/null
-package Moose::Meta::Method::Does;
-
-use strict;
-use warnings;
-
-use Scalar::Util 'blessed', 'weaken', 'looks_like_number', 'refaddr';
-
-our $VERSION = '1.12';
-our $AUTHORITY = 'cpan:STEVAN';
-
-use base 'Moose::Meta::Method',
- 'Class::MOP::Method::Inlined';
-
-sub new {
- my $class = shift;
- my %options = @_;
-
- my $meta = $options{metaclass};
-
- ( ref $options{options} eq 'HASH' )
- || $class->throw_error( "You must pass a hash of options",
- data => $options{options} );
-
- $options{package_name}
- || $class->throw_error(
- "You must supply the package_name parameter" );
-
- my $self = bless {
- 'body' => undef,
- 'package_name' => $options{package_name},
- 'name' => 'does',
- 'options' => $options{options},
- 'associated_metaclass' => $meta,
- '_expected_method_class' => $options{_expected_method_class}
- || 'Moose::Object',
- } => $class;
-
- weaken( $self->{'associated_metaclass'} );
-
- $self->_initialize_body;
-
- return $self;
-}
-
-sub _initialize_body {
- my $self = shift;
-
- my $source = 'sub {';
- $source
- .= "\n"
- . 'defined $_[1] || '
- . $self->_inline_throw_error(
- q{"You must supply a role name to does()"});
- $source .= ";\n" . 'my $name = Scalar::Util::blessed( $_[1] ) ? $_[1]->name : $_[1]';
- $source .= ";\n" . 'return $does{$name} || 0';
- $source .= ";\n" . '}';
-
- my %does = map { $_->name => 1 }
- $self->associated_metaclass->calculate_all_roles_with_inheritance;
-
- my ( $code, $e ) = $self->_compile_code(
- code => $source,
- environment => {
- '%does' => \%does,
- '$meta' => \$self,
- },
- );
-
- $self->throw_error(
- "Could not eval the does method :\n\n$source\n\nbecause :\n\n$e",
- error => $e,
- data => $source,
- ) if $e;
-
- $self->{'body'} = $code;
-}
-
-1;
-
-__END__
-
-=pod
-
-=head1 NAME
-
-Moose::Meta::Method::Does - Method Meta Object for does
-
-=head1 DESCRIPTION
-
-This class is a subclass of L<Class::MOP::Class::Generated> that provides
-Moose-specific functionality for inlining does.
-
-To understand this class, you should read the L<Class::MOP::Class::Generated>
-documentation as well.
-
-=head1 INHERITANCE
-
-C<Moose::Meta::Method::Does> is a subclass of
-L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Generated>.
-
-=head1 METHODS
-
-=over 4
-
-=item B<< Moose::Meta::Method::Does->new(%options) >>
-
-This constructs a new object. It accepts the following options:
-
-=over 8
-
-=item * package_name
-
-The package for the class in which the does is being inlined. This option is
-required.
-
-=item * metaclass
-
-The metaclass for the class this does belongs to. This is optional, as it can
-be set later by calling C<< $metamethod->attach_to_class >>.
-
-=back
-
-=head1 BUGS
-
-See L<Moose/BUGS> for details on reporting bugs.
-
-=head1 AUTHORS
-
-Stevan Little E<lt>stevan@iinteractive.comE<gt>
-
-=head1 COPYRIGHT AND LICENSE
-
-Copyright 2010 by Infinity Interactive, Inc.
-
-L<http://www.iinteractive.com>
-
-This library is free software; you can redistribute it and/or modify
-it under the same terms as Perl itself.
-
-=cut
-
projects / gitmo/Moose.git / commitdiff