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',
);
}
-sub _immutable_options {
- my ( $self, @args ) = @_;
-
- $self->SUPER::_immutable_options(
- inline_destructor => 1,
-
- # Moose always does this when an attribute is created
- inline_accessors => 0,
-
- @args,
- );
-}
-
sub create {
my ($class, $package_name, %options) = @_;
instance_metaclass
constructor_class
destructor_class
+ does_class
error_class
);
}
}
+## Immutability
+
+sub _immutable_options {
+ my ( $self, @args ) = @_;
+
+ $self->SUPER::_immutable_options(
+ inline_destructor => 1,
+ inline_does => 1,
+
+ # Moose always does this when an attribute is created
+ inline_accessors => 0,
+
+ @args,
+ );
+}
+
+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,
+ );
+
+ return unless $does->can_be_inlined;
+
+ $self->add_method( 'does' => $does );
+ $self->_add_inlined_method($does);
+}
+
## -------------------------------------------------
our $error_level;
=item B<< $metaclass->destructor_class($class_name) >>
-These are the names of classes used when making a class
-immutable. These 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->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.
=item B<< $metaclass->error_class($class_name) >>
--- /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;
+
+ 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::Constructor - Method Meta Object for constructors
+
+=head1 DESCRIPTION
+
+This class is a subclass of L<Class::MOP::Method::Constructor> that
+provides additional Moose-specific functionality
+
+To understand this class, you should read the the
+L<Class::MOP::Method::Constructor> documentation as well.
+
+=head1 INHERITANCE
+
+C<Moose::Meta::Method::Constructor> is a subclass of
+L<Moose::Meta::Method> I<and> L<Class::MOP::Method::Constructor>.
+
+=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 2006-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
+
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More;
+use Test::Moose;
+
+{
+ package Role::A;
+
+ use Moose::Role
+}
+
+{
+ package Role::B;
+
+ use Moose::Role
+}
+
+{
+ package Foo;
+
+ use Moose;
+}
+
+{
+ package Bar;
+
+ use Moose;
+
+ with 'Role::A';
+}
+
+{
+ package Baz;
+
+ use Moose;
+
+ with qw( Role::A Role::B );
+}
+
+with_immutable {
+
+ for my $thing ( 'Foo', Foo->new ) {
+ my $name = ref $thing ? 'Foo object' : 'Foo class';
+ $name .= ' (immutable)' if $thing->meta->is_immutable;
+
+ ok(
+ !$thing->does('Role::A'),
+ "$name does not do Role::A"
+ );
+ ok(
+ !$thing->does('Role::B'),
+ "$name does not do Role::B"
+ );
+
+ ok(
+ !$thing->does( Role::A->meta ),
+ "$name does not do Role::A (passed as object)"
+ );
+ ok(
+ !$thing->does( Role::B->meta ),
+ "$name does not do Role::B (passed as object)"
+ );
+
+ ok(
+ !$thing->DOES('Role::A'),
+ "$name does not do Role::A (using DOES)"
+ );
+ ok(
+ !$thing->DOES('Role::B'),
+ "$name does not do Role::B (using DOES)"
+ );
+ }
+
+ for my $thing ( 'Bar', Bar->new ) {
+ my $name = ref $thing ? 'Bar object' : 'Bar class';
+ $name .= ' (immutable)' if $thing->meta->is_immutable;
+
+ ok(
+ $thing->does('Role::A'),
+ "$name does Role::A"
+ );
+ ok(
+ !$thing->does('Role::B'),
+ "$name does not do Role::B"
+ );
+
+ ok(
+ $thing->does( Role::A->meta ),
+ "$name does Role::A (passed as object)"
+ );
+ ok(
+ !$thing->does( Role::B->meta ),
+ "$name does not do Role::B (passed as object)"
+ );
+
+ ok(
+ $thing->DOES('Role::A'),
+ "$name does Role::A (using DOES)"
+ );
+ ok(
+ !$thing->DOES('Role::B'),
+ "$name does not do Role::B (using DOES)"
+ );
+ }
+
+ for my $thing ( 'Baz', Baz->new ) {
+ my $name = ref $thing ? 'Baz object' : 'Baz class';
+ $name .= ' (immutable)' if $thing->meta->is_immutable;
+
+ ok(
+ $thing->does('Role::A'),
+ "$name does Role::A"
+ );
+ ok(
+ $thing->does('Role::B'),
+ "$name does Role::B"
+ );
+
+ ok(
+ $thing->does( Role::A->meta ),
+ "$name does Role::A (passed as object)"
+ );
+ ok(
+ $thing->does( Role::B->meta ),
+ "$name does Role::B (passed as object)"
+ );
+
+ ok(
+ $thing->DOES('Role::A'),
+ "$name does Role::A (using DOES)"
+ );
+ ok(
+ $thing->DOES('Role::B'),
+ "$name does Role::B (using DOES)"
+ );
+ }
+
+}
+qw( Foo Bar Baz );
+
+done_testing;
projects / gitmo/Moose.git / commitdiff