Revision history for Perl extension Moose
-0.64
+0.65
+ * Moose and Moose::Meta::Method::Overridden
+ - If an overridden method called super(), and then the
+ superclass's method (not overridden) _also_ called super(),
+ Moose went into an endless recursion loop. Test provided by
+ Chris Prather. (Dave Rolsky)
+ * Moose::Meta::TypeConstraint
+ - Add some explanation for a few explanationless methods (gphat)
+
+0.64 Wed, December 31, 2008
* Moose::Meta::Method::Accessor
- Always inline predicate and clearer methods (Sartak)
+ * Moose::Meta::Attribute
+ - Support for parameterized traits (Sartak)
+ - verify_against_type_constraint method to avoid duplication
+ and enhance extensibility (Sartak)
+ * Moose::Meta::Class
+ - Tests (but no support yet) for parameterized traits (Sartak)
+ * Moose
+ - Require Class::MOP 0.75+, which has the side effect of making
+ sure we work on Win32. (Dave Rolsky)
0.63 Mon, December 8, 2008
* Moose::Unsweetened
- When a class does not provide all of a role's required
methods, the error thrown now mentions all of the missing
methods, as opposed to just the first one found. Requested by
- Michael Schwern (RT #41119). (Dave Rolsky)
+ Curtis Poe (RT #41119). (Dave Rolsky)
* Moose::Meta::Method::Constructor
- Moose will no longer inline a constructor for your class
ArrayRef[Int] # array or integers
HashRef[Object] # a hash with object values
They can also be nested:
- ArrayRef[HashRef[RegExpr]] # an array of hashes with regexpr values
+ ArrayRef[HashRef[RegexpRef]] # an array of hashes with regex values
And work with the type unions as well:
ArrayRef[Int | Str] # array of integers of strings
t/020_attributes/021_method_generation_rules.t
t/020_attributes/022_legal_options_for_inheritance.t
t/020_attributes/023_attribute_names.t
+t/020_attributes/024_attribute_traits_parameterized.t
t/030_roles/001_meta_role.t
t/030_roles/002_role.t
t/030_roles/003_apply_role.t
t/050_metaclasses/017_use_base_of_moose.t
t/050_metaclasses/018_throw_error.t
t/050_metaclasses/019_create_anon_with_required_attr.t
+t/050_metaclasses/020_metaclass_parameterized_traits.t
t/060_compat/001_module_refresh_compat.t
t/060_compat/002_moose_respects_base.t
t/060_compat/003_foreign_inheritence.t
t/300_immutable/010_constructor_is_not_moose.t
t/300_immutable/011_constructor_is_wrapped.t
t/300_immutable/012_default_values.t
+t/300_immutable/013_immutable_roundtrip.t
t/400_moose_util/001_moose_util.t
t/400_moose_util/002_moose_util_does_role.t
t/400_moose_util/003_moose_util_search_class_by_role.t
use strict;
use warnings;
use inc::Module::Install;
+use 5.008;
check_conflicts();
name 'Moose';
+perl_version '5.008';
all_from 'lib/Moose.pm';
license 'perl';
# prereqs
-requires 'perl' => '5.008';
requires 'Scalar::Util' => '1.19';
requires 'Carp';
-requires 'Class::MOP' => '0.72';
+requires 'Class::MOP' => '0.75';
requires 'List::MoreUtils' => '0.12';
requires 'Sub::Exporter' => '0.972';
requires 'Task::Weaken' => '0';
# things the tests need
build_requires 'Test::More' => '0.77';
build_requires 'Test::Exception' => '0.21';
-build_requires 'Test::LongString';
tests_recursive();
-Moose version 0.63
+Moose version 0.64
===========================
See the individual module documentation for more information
use 5.008;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Exporter;
-use Class::MOP 0.72;
+use Class::MOP 0.75;
use Moose::Meta::Class;
use Moose::Meta::TypeConstraint;
use Moose::Util::TypeConstraints;
use Moose::Util ();
+sub _caller_info {
+ my $level = @_ ? ($_[0] + 1) : 2;
+ my %info;
+ @info{qw(package file line)} = caller($level);
+ return \%info;
+}
+
sub throw_error {
# FIXME This
shift;
my $class = shift;
my $name = shift;
croak 'Usage: has \'name\' => ( key => value, ... )' if @_ == 1;
- my %options = @_;
+ my %options = ( definition_context => _caller_info(), @_ );
my $attrs = ( ref($name) eq 'ARRAY' ) ? $name : [ ($name) ];
Class::MOP::Class->initialize($class)->add_attribute( $_, %options ) for @$attrs;
}
Moose::Util::add_method_modifier($class, 'around', \@_);
}
+our $SUPER_PACKAGE;
+our $SUPER_BODY;
+our @SUPER_ARGS;
+
sub super {
- return unless our $SUPER_BODY; $SUPER_BODY->(our @SUPER_ARGS);
+ # This check avoids a recursion loop - see
+ # t/100_bugs/020_super_recursion.t
+ return if defined $SUPER_PACKAGE && $SUPER_PACKAGE ne caller();
+ return unless $SUPER_BODY; $SUPER_BODY->(@SUPER_ARGS);
}
sub override {
Sam (mugwump) Vilain
+Cory (gphat) Watson
+
... and many other #moose folks
=head1 COPYRIGHT AND LICENSE
=head1 SYNOPSIS
package Human;
-
+
use Moose;
use Moose::Util::TypeConstraints;
-
+
subtype 'Gender'
=> as 'Str'
=> where { $_ =~ m{^[mf]$}s };
-
+
has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
-
+
has 'mother' => ( is => 'ro', isa => 'Human' );
has 'father' => ( is => 'ro', isa => 'Human' );
-
+
use overload '+' => \&_overload_add, fallback => 1;
-
+
sub _overload_add {
- my ($one, $two) = @_;
-
+ my ( $one, $two ) = @_;
+
die('Only male and female humans may create children')
- if ($one->gender() eq $two->gender());
-
- my ( $mother, $father ) = ( $one->gender eq 'f' ? ($one, $two) : ($two, $one) );
-
+ if ( $one->gender() eq $two->gender() );
+
+ my ( $mother, $father )
+ = ( $one->gender eq 'f' ? ( $one, $two ) : ( $two, $one ) );
+
my $gender = 'f';
- $gender = 'm' if (rand() >= 0.5);
-
+ $gender = 'm' if ( rand() >= 0.5 );
+
return Human->new(
gender => $gender,
mother => $mother,
=head2 bey2
package Human::Gene::bey2;
-
+
use Moose;
use Moose::Util::TypeConstraints;
-
+
type 'bey2Color' => where { $_ =~ m{^(?:brown|blue)$}s };
-
+
has 'color' => ( is => 'ro', isa => 'bey2Color' );
This class is really simple. All we need to know about the bey2
=head2 gey
package Human::Gene::gey;
-
+
use Moose;
use Moose::Util::TypeConstraints;
-
+
type 'geyColor' => where { $_ =~ m{^(?:green|blue)$}s };
-
+
has 'color' => ( is => 'ro', isa => 'geyColor' );
The gey gene is nearly identical to the bey2, except that it
characteristics that makes up a Human.
package Human::EyeColor;
-
+
use Moose;
use Moose::Util::TypeConstraints;
-
+
subtype 'bey2Gene'
=> as 'Object'
=> where { $_->isa('Human::Gene::bey2') };
-
+
coerce 'bey2Gene'
=> from 'Str'
=> via { Human::Gene::bey2->new( color => $_ ) };
-
+
subtype 'geyGene'
=> as 'Object'
=> where { $_->isa('Human::Gene::gey') };
-
+
coerce 'geyGene'
=> from 'Str'
=> via { Human::Gene::gey->new( color => $_ ) };
-
+
has 'bey2_1' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
has 'bey2_2' => ( is => 'ro', isa => 'bey2Gene', coerce => 1 );
-
- has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
- has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
+
+ has 'gey_1' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
+ has 'gey_2' => ( is => 'ro', isa => 'geyGene', coerce => 1 );
So, we now have a class that can hold the four genes that dictate
eye color. This isn't quite enough, as we also need to calculate
the bey and gey2 blue genes are recessive to both brown and green.
sub color {
- my ( $self ) = @_;
-
- return 'brown' if ($self->bey2_1->color() eq 'brown' or $self->bey2_2->color() eq 'brown');
- return 'green' if ($self->gey_1->color() eq 'green' or $self->gey_2->color() eq 'green');
+ my ($self) = @_;
+
+ return 'brown'
+ if ( $self->bey2_1->color() eq 'brown'
+ or $self->bey2_2->color() eq 'brown' );
+
+ return 'green'
+ if ( $self->gey_1->color() eq 'green'
+ or $self->gey_2->color() eq 'green' );
+
return 'blue';
}
the gene selection in human reproduction.
use overload '+' => \&_overload_add, fallback => 1;
-
+
sub _overload_add {
- my ($one, $two) = @_;
-
+ my ( $one, $two ) = @_;
+
my $one_bey2 = 'bey2_' . _rand2();
my $two_bey2 = 'bey2_' . _rand2();
-
+
my $one_gey = 'gey_' . _rand2();
my $two_gey = 'gey_' . _rand2();
-
+
return Human::EyeColor->new(
bey2_1 => $one->$one_bey2->color(),
bey2_2 => $two->$two_bey2->color(),
gey_2 => $two->$two_gey->color(),
);
}
-
+
sub _rand2 {
return 1 + int( rand(2) );
}
we'll coerce an arrayref of colors in to an EyeColor object.
use List::MoreUtils qw( zip );
-
+
subtype 'EyeColor'
=> as 'Object'
=> where { $_->isa('Human::EyeColor') };
-
+
coerce 'EyeColor'
=> from 'ArrayRef'
- => via {
- my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
- return Human::EyeColor->new( zip( @genes, @$_ ) );
- };
-
- has 'eye_color' => ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
+ => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
+ return Human::EyeColor->new( zip( @genes, @$_ ) ); };
+
+ has 'eye_color' =>
+ ( is => 'ro', isa => 'EyeColor', coerce => 1, required => 1 );
And then in the _overload_add() of the Human class we modify
the creation of the child object to include the addition of
the mother and father's eye colors.
return Human->new(
- gender => $gender,
+ gender => $gender,
eye_color => ( $one->eye_color() + $two->eye_color() ),
- mother => $mother,
- father => $father,
+ mother => $mother,
+ father => $father,
);
=head1 CONCLUSION
package BankAccount;
use Moose;
-
- has 'balance' => (isa => 'Int', is => 'rw', default => 0);
-
+
+ has 'balance' => ( isa => 'Int', is => 'rw', default => 0 );
+
sub deposit {
- my ($self, $amount) = @_;
- $self->balance($self->balance + $amount);
+ my ( $self, $amount ) = @_;
+ $self->balance( $self->balance + $amount );
}
-
+
sub withdraw {
- my ($self, $amount) = @_;
+ my ( $self, $amount ) = @_;
my $current_balance = $self->balance();
- ($current_balance >= $amount)
+ ( $current_balance >= $amount )
|| confess "Account overdrawn";
- $self->balance($current_balance - $amount);
+ $self->balance( $current_balance - $amount );
}
-
+
package CheckingAccount;
use Moose;
-
+
extends 'BankAccount';
-
- has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
-
+
+ has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' );
+
before 'withdraw' => sub {
- my ($self, $amount) = @_;
+ my ( $self, $amount ) = @_;
my $overdraft_amount = $amount - $self->balance();
- if ($self->overdraft_account && $overdraft_amount > 0) {
+ if ( $self->overdraft_account && $overdraft_amount > 0 ) {
$self->overdraft_account->withdraw($overdraft_amount);
$self->deposit($overdraft_amount);
}
The first recipe demonstrated how to build very basic Moose classes,
focusing on creating and manipulating attributes. The objects in that
-recipe very data-oriented, and did not have much in the way of
+recipe were very data-oriented, and did not have much in the way of
behavior (i.e. methods). In this recipe, we expand upon the concepts
from the first recipe to include some real behavior. In particular, we
-should how you can use a method modifier to implement new behavior for
-a method.
+show how you can use a method modifier to implement new behavior for a
+method.
The classes in the SYNOPSIS show two kinds of bank account. A simple
bank account has one attribute, the balance, and two behaviors,
The first class, B<BankAccount>, introduces a new attribute feature, a
default value:
- has 'balance' => (isa => 'Int', is => 'rw', default => 0);
+ has 'balance' => ( isa => 'Int', is => 'rw', default => 0 );
This says that a B<BankAccount> has a C<balance> attribute, which has
a C<Int> type constraint, a read/write accessor, and a default value
B<BankAccount>. The next line introduces yet another new attribute
feature, class-based type constraints:
- has 'overdraft_account' => (isa => 'BankAccount', is => 'rw');
+ has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' );
Up until now, we have only seen the C<Int> type constraint, which (as
we saw in the first recipe) is a builtin type constraint. The
modifier.
before 'withdraw' => sub {
- my ($self, $amount) = @_;
+ my ( $self, $amount ) = @_;
my $overdraft_amount = $amount - $self->balance();
- if ($self->overdraft_account && $overdraft_amount > 0) {
+ if ( $self->overdraft_account && $overdraft_amount > 0 ) {
$self->overdraft_account->withdraw($overdraft_amount);
$self->deposit($overdraft_amount);
}
C<SUPER::> to get the same effect:
sub withdraw {
- my ($self, $amount) = @_;
+ my ( $self, $amount ) = @_;
my $overdraft_amount = $amount - $self->balance();
- if ($self->overdraft_account && $overdraft_amount > 0) {
+ if ( $self->overdraft_account && $overdraft_amount > 0 ) {
$self->overdraft_account->withdraw($overdraft_amount);
$self->deposit($overdraft_amount);
}
package BinaryTree;
use Moose;
-
- has 'node' => (is => 'rw', isa => 'Any');
-
+
+ has 'node' => ( is => 'rw', isa => 'Any' );
+
has 'parent' => (
is => 'rw',
- isa => 'BinaryTree',
+ isa => 'BinaryTree',
predicate => 'has_parent',
weak_ref => 1,
);
-
+
has 'left' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_left',
+ is => 'rw',
+ isa => 'BinaryTree',
+ predicate => 'has_left',
lazy => 1,
- default => sub { BinaryTree->new(parent => $_[0]) },
+ default => sub { BinaryTree->new( parent => $_[0] ) },
);
-
+
has 'right' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_right',
- lazy => 1,
- default => sub { BinaryTree->new(parent => $_[0]) },
+ is => 'rw',
+ isa => 'BinaryTree',
+ predicate => 'has_right',
+ lazy => 1,
+ default => sub { BinaryTree->new( parent => $_[0] ) },
);
-
+
before 'right', 'left' => sub {
- my ($self, $tree) = @_;
- $tree->parent($self) if defined $tree;
+ my ( $self, $tree ) = @_;
+ $tree->parent($self) if defined $tree;
};
=head1 DESCRIPTION
Now, let's start with the code. Our first attribute is the C<node>
slot, defined as such:
- has 'node' => (is => 'rw', isa => 'Any');
+ has 'node' => ( is => 'rw', isa => 'Any' );
If you recall from the previous recipes, this slot will have a read/write
accessor generated for it, and has a type constraint on it. The new item here is
has 'parent' => (
is => 'rw',
- isa => 'BinaryTree',
+ isa => 'BinaryTree',
predicate => 'has_parent',
weak_ref => 1,
);
save for different names, so I will just describe one here:
has 'left' => (
- is => 'rw',
- isa => 'BinaryTree',
- predicate => 'has_left',
+ is => 'rw',
+ isa => 'BinaryTree',
+ predicate => 'has_left',
lazy => 1,
- default => sub { BinaryTree->new(parent => $_[0]) },
+ default => sub { BinaryTree->new( parent => $_[0] ) },
);
You already know what the C<is>, C<isa> and C<predicate> options do, but now we
(ARRAY ref, HASH ref, object instance, etc) you would need to
wrap it in a CODE reference, so this:
- has 'foo' => (is => 'rw', default => []);
+ has 'foo' => ( is => 'rw', default => [] );
is actually illegal in Moose. Instead, what you really want is this:
- has 'foo' => (is => 'rw', default => sub { [] });
+ has 'foo' => ( is => 'rw', default => sub { [] } );
This ensures that each instance of this class will get its own ARRAY ref in the
C<foo> slot.
where the slot will be stored. This can come in quite handy at times, as
illustrated above, with this code:
- default => sub { BinaryTree->new(parent => $_[0]) },
+ default => sub { BinaryTree->new( parent => $_[0] ) },
The default value being generated is a new C<BinaryTree> instance for the
C<left> (or C<right>) slot. Here we set up the correct relationship by passing
that would require us to implement all those features we got automatically (type
constraints, lazy initialization, and so on). Instead, we use method modifiers
again:
-
+
before 'right', 'left' => sub {
- my ($self, $tree) = @_;
- $tree->parent($self) if defined $tree;
+ my ( $self, $tree ) = @_;
+ $tree->parent($self) if defined $tree;
};
This is a C<before> modifier, just like we saw in the second recipe, but with
package Request;
use Moose;
use Moose::Util::TypeConstraints;
-
+
use HTTP::Headers ();
use Params::Coerce ();
use URI ();
-
+
subtype 'Header'
=> as 'Object'
=> where { $_->isa('HTTP::Headers') };
-
+
coerce 'Header'
=> from 'ArrayRef'
- => via { HTTP::Headers->new( @{ $_ } ) }
+ => via { HTTP::Headers->new( @{$_} ) }
=> from 'HashRef'
- => via { HTTP::Headers->new( %{ $_ } ) };
-
+ => via { HTTP::Headers->new( %{$_} ) };
+
subtype 'Uri'
=> as 'Object'
=> where { $_->isa('URI') };
-
+
coerce 'Uri'
=> from 'Object'
- => via { $_->isa('URI')
- ? $_
- : Params::Coerce::coerce( 'URI', $_ ) }
+ => via { $_->isa('URI')
+ ? $_
+ : Params::Coerce::coerce( 'URI', $_ ); }
=> from 'Str'
=> via { URI->new( $_, 'http' ) };
-
+
subtype 'Protocol'
- => as Str
+ => as 'Str'
=> where { /^HTTP\/[0-9]\.[0-9]$/ };
-
- has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
- has 'uri' => (is => 'rw', isa => 'Uri', coerce => 1);
- has 'method' => (is => 'rw', isa => 'Str');
- has 'protocol' => (is => 'rw', isa => 'Protocol');
+
+ has 'base' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+ has 'uri' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+ has 'method' => ( is => 'rw', isa => 'Str' );
+ has 'protocol' => ( is => 'rw', isa => 'Protocol' );
has 'headers' => (
is => 'rw',
isa => 'Header',
coerce => 1,
- default => sub { HTTP::Headers->new }
+ default => sub { HTTP::Headers->new }
);
=head1 DESCRIPTION
-This recipe introduces the idea of type coercions, and the C<coerce>
-keyword. Coercions can be attached to existing type constraints,
-and can be used to transform input of one type into input of another
-type. This can be an extremely powerful tool if used correctly, which
-is why it is off by default. If you want your accessor to attempt
-a coercion, you must specifically ask for it with the B<coerce> option.
+This recipe introduces the idea of type coercions, and the C<coerce>
+keyword. Coercions can be attached to existing type constraints, and
+can be used to transform input of one type into input of another
+type. This can be an extremely powerful tool if used correctly, which
+is why it is off by default. If you want your accessor to attempt a
+coercion, you must specifically ask for it with the B<coerce> option.
-Now, onto the coercions.
+Now, onto the coercions.
-First we need to create a subtype to attach our coercion to. Here we
-create a basic I<Header> subtype, which matches any instance of the
+First we need to create a subtype to attach our coercion to. Here we
+create a basic I<Header> subtype, which matches any instance of the
class B<HTTP::Headers>:
subtype 'Header'
The simplest thing from here would be create an accessor declaration
like this:
- has 'headers' => (
+ has 'headers' => (
is => 'rw',
isa => 'Header',
- default => sub { HTTP::Headers->new }
+ default => sub { HTTP::Headers->new }
);
-We would then have a self-validating accessor whose default value is
-an empty instance of B<HTTP::Headers>. This is nice, but it is not
+We would then have a self-validating accessor whose default value is
+an empty instance of B<HTTP::Headers>. This is nice, but it is not
ideal.
The constructor for B<HTTP::Headers> accepts a list of key-value pairs
-representing the HTTP header fields. In Perl, such a list could
-easily be stored in an ARRAY or HASH reference. We would like our
-class's interface to be able to accept this list of key-value pairs
-in place of the B<HTTP::Headers> instance, and just DWIM. This is where
+representing the HTTP header fields. In Perl, such a list could easily
+be stored in an ARRAY or HASH reference. We would like our class's
+interface to be able to accept this list of key-value pairs in place
+of the B<HTTP::Headers> instance, and just DWIM. This is where
coercion can help. First, let's declare our coercion:
coerce 'Header'
=> from 'ArrayRef'
- => via { HTTP::Headers->new( @{ $_ } ) }
+ => via { HTTP::Headers->new( @{$_} ) }
=> from 'HashRef'
- => via { HTTP::Headers->new( %{ $_ } ) };
+ => via { HTTP::Headers->new( %{$_} ) };
We first tell it that we are attaching the coercion to the 'Header'
-subtype. We then give it a set of C<from> clauses which map other
-subtypes to coercion routines (through the C<via> keyword). Fairly
-simple really; however, this alone does nothing. We have to tell
-our attribute declaration to actually use the coercion, like so:
+subtype. We then give it a set of C<from> clauses which map other
+subtypes to coercion routines (through the C<via> keyword). Fairly
+simple really; however, this alone does nothing. We have to tell our
+attribute declaration to actually use the coercion, like so:
- has 'headers' => (
+ has 'headers' => (
is => 'rw',
isa => 'Header',
coerce => 1,
- default => sub { HTTP::Headers->new }
+ default => sub { HTTP::Headers->new }
);
This will coerce any B<ArrayRef> or B<HashRef> which is passed into
the C<headers> accessor into an instance of B<HTTP::Headers>. So the
the following lines of code are all equivalent:
- $foo->headers(HTTP::Headers->new(bar => 1, baz => 2));
- $foo->headers([ 'bar', 1, 'baz', 2 ]);
- $foo->headers({ bar => 1, baz => 2 });
+ $foo->headers( HTTP::Headers->new( bar => 1, baz => 2 ) );
+ $foo->headers( [ 'bar', 1, 'baz', 2 ] );
+ $foo->headers( { bar => 1, baz => 2 } );
-As you can see, careful use of coercions can produce a very open
-interface for your class, while still retaining the "safety" of
-your type constraint checks.
+As you can see, careful use of coercions can produce a very open
+interface for your class, while still retaining the "safety" of your
+type constraint checks.
-Our next coercion takes advantage of the power of CPAN to handle
-the details of our coercion. In this particular case it uses the
+Our next coercion takes advantage of the power of CPAN to handle the
+details of our coercion. In this particular case it uses the
L<Params::Coerce> module, which fits in rather nicely with L<Moose>.
-Again, we create a simple subtype to represent instances of the
-B<URI> class:
+Again, we create a simple subtype to represent instances of the B<URI>
+class:
subtype 'Uri'
=> as 'Object'
coerce 'Uri'
=> from 'Object'
- => via { $_->isa('URI')
- ? $_
- : Params::Coerce::coerce( 'URI', $_ ) }
+ => via { $_->isa('URI')
+ ? $_
+ : Params::Coerce::coerce( 'URI', $_ ); }
=> from 'Str'
=> via { URI->new( $_, 'http' ) };
-The first C<from> clause we introduce is for the 'Object' subtype. An 'Object'
-is simply any C<bless>ed value. This means that if the coercion encounters
-another object, it should use this clause. Now we look at the C<via> block.
-First it checks to see if the object is a B<URI> instance. Since the coercion
-process occurs prior to any type constraint checking, it is entirely possible
-for this to happen, and if it does happen, we simply want to pass the instance
-on through. However, if it is not an instance of B<URI>, then we need to coerce
-it. This is where L<Params::Coerce> can do its magic, and we can just use its
-return value. Simple really, and much less work since we used a module from CPAN
-:)
-
-The second C<from> clause is attached to the 'Str' subtype, and
-illustrates how coercions can also be used to handle certain
-'default' behaviors. In this coercion, we simple take any string
-and pass it to the B<URI> constructor along with the default
-'http' scheme type.
-
-And of course, our coercions do nothing unless they are told to,
-like so:
-
- has 'base' => (is => 'rw', isa => 'Uri', coerce => 1);
- has 'uri' => (is => 'rw', isa => 'Uri', coerce => 1);
-
-As you can see, re-using the coercion allows us to enforce a
+The first C<from> clause we introduce is for the 'Object' subtype. An
+'Object' is simply any C<bless>ed value. This means that if the
+coercion encounters another object, it should use this clause. Now we
+look at the C<via> block. First it checks to see if the object is a
+B<URI> instance. Since the coercion process occurs prior to any type
+constraint checking, it is entirely possible for this to happen, and
+if it does happen, we simply want to pass the instance on
+through. However, if it is not an instance of B<URI>, then we need to
+coerce it. This is where L<Params::Coerce> can do its magic, and we
+can just use its return value. Simple really, and much less work since
+we used a module from CPAN :)
+
+The second C<from> clause is attached to the 'Str' subtype, and
+illustrates how coercions can also be used to handle certain 'default'
+behaviors. In this coercion, we simple take any string and pass it to
+the B<URI> constructor along with the default 'http' scheme type.
+
+And of course, our coercions do nothing unless they are told to, like
+so:
+
+ has 'base' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+ has 'uri' => ( is => 'rw', isa => 'Uri', coerce => 1 );
+
+As you can see, re-using the coercion allows us to enforce a
consistent and very flexible API across multiple accessors.
=head1 CONCLUSION
-This recipe illustrated the power of coercions to build a more
-flexible and open API for your accessors, while still retaining
-all the safety that comes from using Moose's type constraints.
-Using coercions it becomes simple to manage (from a single
-location) a consistent API not only across multiple accessors,
-but across multiple classes as well.
+This recipe illustrated the power of coercions to build a more
+flexible and open API for your accessors, while still retaining all
+the safety that comes from using Moose's type constraints. Using
+coercions it becomes simple to manage (from a single location) a
+consistent API not only across multiple accessors, but across multiple
+classes as well.
-In the next recipe, we will introduce roles, a concept originally
-borrowed from Smalltalk, which made its way into Perl 6, and
-now into Moose.
+In the next recipe, we will introduce roles, a concept originally
+borrowed from Smalltalk, which made its way into Perl 6, and now into
+Moose.
=head1 AUTHOR
package Point;
use Moose;
- has 'x' => (isa => 'Int', is => 'ro');
- has 'y' => (isa => 'Int', is => 'rw');
+ has 'x' => ( isa => 'Int', is => 'ro' );
+ has 'y' => ( isa => 'Int', is => 'rw' );
__PACKAGE__->meta->make_immutable;
use Moose -traits => [ 'Big', 'Blue' ];
- has 'animal' =>
- ( traits => [ 'Big', 'Blue' ],
- ...
- );
+ has 'animal' => (
+ traits => [ 'Big', 'Blue' ],
+ ...
+ );
If your extension applies to any other metaclass, or the object base
class, you cannot use the trait mechanism.
Moose::Exporter->setup_import_methods( also => 'Moose' );
sub init_meta {
- shift; # just your package name
+ shift; # just your package name
my %options = @_;
return Moose->init_meta(
use MooseX::Embiggen::Role::Meta::Class;
use MooseX::Embiggen::Role::Meta::Attribute;
- use MooseX::Embiggen::Role::Meta::Method::Constructor
+ use MooseX::Embiggen::Role::Meta::Method::Constructor;
use MooseX::Embiggen::Role::Object;
Moose::Exporter->setup_import_methods( also => 'Moose' );
sub init_meta {
- shift; # just your package name
+ shift; # just your package name
my %options = @_;
Moose->init_meta(%options);
use strict;
use warnings;
+ use Moose ();
use Moose::Exporter;
use Moose::Util::MetaRole;
use MooseX::Debugging::Role::Object;
shift;
my %options = @_;
- Moose::Util::MetaRole::apply_base_object_roles(
+ Moose->init_meta(%options);
+
+ Moose::Util::MetaRole::apply_base_class_roles(
for_class => $options{for_class},
- role => ['MooseX::Debugging::Role::Object'],
+ roles => ['MooseX::Debugging::Role::Object'],
);
}
-
package MooseX::Debugging::Role::Object;
after 'BUILD' => sub {
my $self = shift;
warn "Made a new " . ref $self . " object\n";
- }
+ };
=head1 DESCRIPTION
=head1 SYNOPSIS
- package MyApp::Meta::Attribute::Labeled;
- use Moose;
- extends 'Moose::Meta::Attribute';
-
- has label => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_label',
- );
-
- package Moose::Meta::Attribute::Custom::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
-
- package MyApp::Website;
- use Moose;
- use MyApp::Meta::Attribute::Labeled;
-
- has url => (
- metaclass => 'Labeled',
- is => 'rw',
- isa => 'Str',
- label => "The site's URL",
- );
-
- has name => (
- is => 'rw',
- isa => 'Str',
- );
-
- sub dump {
- my $self = shift;
-
- # iterate over all the attributes in $self
- my %attributes = %{ $self->meta->get_attribute_map };
- while (my ($name, $attribute) = each %attributes) {
-
- # print the label if available
- if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
- && $attribute->has_label) {
- print $attribute->label;
- }
- # otherwise print the name
- else {
- print $name;
- }
-
- # print the attribute's value
- my $reader = $attribute->get_read_method;
- print ": " . $self->$reader . "\n";
- }
- }
-
- package main;
- my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
- $app->dump;
+ package MyApp::Meta::Attribute::Labeled;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
+
+ has label => (
+ is => 'rw',
+ isa => 'Str',
+ predicate => 'has_label',
+ );
+
+ package Moose::Meta::Attribute::Custom::Labeled;
+ sub register_implementation {'MyApp::Meta::Attribute::Labeled'}
+
+ package MyApp::Website;
+ use Moose;
+ use MyApp::Meta::Attribute::Labeled;
+
+ has url => (
+ metaclass => 'Labeled',
+ is => 'rw',
+ isa => 'Str',
+ label => "The site's URL",
+ );
+
+ has name => (
+ is => 'rw',
+ isa => 'Str',
+ );
+
+ sub dump {
+ my $self = shift;
+
+ # iterate over all the attributes in $self
+ my %attributes = %{ $self->meta->get_attribute_map };
+ while ( my ( $name, $attribute ) = each %attributes ) {
+
+ # print the label if available
+ if ( $attribute->isa('MyApp::Meta::Attribute::Labeled')
+ && $attribute->has_label ) {
+ print $attribute->label;
+ }
+
+ # otherwise print the name
+ else {
+ print $name;
+ }
+
+ # print the attribute's value
+ my $reader = $attribute->get_read_method;
+ print ": " . $self->$reader . "\n";
+ }
+ }
+
+ package main;
+ my $app = MyApp::Website->new( url => "http://google.com", name => "Google" );
+ $app->dump;
=head1 SUMMARY
These objects have methods and (surprisingly) attributes. Let's look at a
concrete example.
- has 'x' => (isa => 'Int', is => 'ro');
- has 'y' => (isa => 'Int', is => 'rw');
+ has 'x' => ( isa => 'Int', is => 'ro' );
+ has 'y' => ( isa => 'Int', is => 'rw' );
Ahh, the veritable x and y of the Point example. Internally, every Point has an
x object and a y object. They have methods (such as "get_value") and attributes
So you have a C<$point> object, which has C<x> and C<y> methods. How can you
actually access the objects behind these attributes? Here's one way:
- $point->meta->get_attribute_map()
+ $point->meta->get_attribute_map()
C<get_attribute_map> returns a hash reference that maps attribute names to
their objects. In our case, C<get_attribute_map> might return something that
looks like the following:
- {
- x => Moose::Meta::Attribute=HASH(0x196c23c),
- y => Moose::Meta::Attribute=HASH(0x18d1690),
- }
+ {
+ x => Moose::Meta::Attribute=HASH(0x196c23c),
+ y => Moose::Meta::Attribute=HASH(0x18d1690),
+ }
Another way to get a handle on an attribute's object is
C<< $self->meta->get_attribute('name') >>. Here's one thing you can do now that
you can interact with the attribute's object directly:
- print $point->meta->get_attribute('x')->type_constraint;
- => Int
+ print $point->meta->get_attribute('x')->type_constraint;
+ => Int
(As an aside, it's not called C<< ->isa >> because C<< $obj->isa >> is already
taken)
We get the ball rolling by creating a new attribute metaclass. It starts off
somewhat ungloriously.
- package MyApp::Meta::Attribute::Labeled;
- use Moose;
- extends 'Moose::Meta::Attribute';
+ package MyApp::Meta::Attribute::Labeled;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
You subclass metaclasses the same way you subclass regular classes. (Extra
credit: how in the actual hell can you use the MOP to extend itself?)
- has label => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_label',
- );
+ has label => (
+ is => 'rw',
+ isa => 'Str',
+ predicate => 'has_label',
+ );
Hey, this looks pretty reasonable! This is plain jane Moose code. Recipe 1
fare. This is merely making a new attribute. An attribute that attributes have.
C<predicate> is a standard part of C<has>. It just creates a method that asks
the question "Does this attribute have a value?"
- package Moose::Meta::Attribute::Custom::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
+ package Moose::Meta::Attribute::Custom::Labeled;
+ sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
This lets Moose discover our new metaclass. That way attributes can actually
use it. More on what this is doing in a moment.
Note that we're done defining the new metaclass! Only nine lines of code, and
not particularly difficult lines, either. Now to start using the metaclass.
- package MyApp::Website;
- use Moose;
- use MyApp::Meta::Attribute::Labeled;
+ package MyApp::Website;
+ use Moose;
+ use MyApp::Meta::Attribute::Labeled;
Nothing new here. We do have to actually load our metaclass to be able to use
it.
- has url => (
- metaclass => 'Labeled',
- is => 'rw',
- isa => 'Str',
- label => "The site's URL",
- );
+ has url => (
+ metaclass => 'Labeled',
+ is => 'rw',
+ isa => 'Str',
+ label => "The site's URL",
+ );
Ah ha! Now we're using the metaclass. We're adding a new attribute, C<url>, to
C<MyApp::Website>. C<has> lets you set the metaclass of the attribute.
Finally, we see that C<has> is setting our new meta-attribute, C<label>, to
C<"The site's URL">. We can access this meta-attribute with:
- $website->meta->get_attribute('url')->label()
+ $website->meta->get_attribute('url')->label()
Well, back to the code.
- has name => (
- is => 'rw',
- isa => 'Str',
- );
+ has name => (
+ is => 'rw',
+ isa => 'Str',
+ );
Of course, you don't have to use the new metaclass for B<all> new attributes.
Now we begin defining a method that will dump the C<MyApp::Website> instance
for human readers.
- sub dump {
- my $self = shift;
+ sub dump {
+ my $self = shift;
- # iterate over all the attributes in $self
- my %attributes = %{ $self->meta->get_attribute_map };
- while (my ($name, $attribute) = each %attributes) {
+ # iterate over all the attributes in $self
+ my %attributes = %{ $self->meta->get_attribute_map };
+ while ( my ( $name, $attribute ) = each %attributes ) {
Recall that C<get_attribute_map> returns a hashref of attribute names and their
associated objects.
- # print the label if available
- if ($attribute->isa('MyApp::Meta::Attribute::Labeled')
- && $attribute->has_label) {
- print $attribute->label;
- }
+ # print the label if available
+ if ( $attribute->isa('MyApp::Meta::Attribute::Labeled')
+ && $attribute->has_label ) {
+ print $attribute->label;
+ }
We have two checks here. The first is "is this attribute an instance of
C<MyApp::Meta::Attribute::Labeled>?". It's good to code defensively. Even if
defined in the new metaclass as the "predicate". If we pass both checks, we
print the attribute's label.
- # otherwise print the name
- else {
- print $name;
- }
+ # otherwise print the name
+ else {
+ print $name;
+ }
Another good, defensive coding practice: Provide reasonable defaults.
- # print the attribute's value
- my $reader = $attribute->get_read_method;
- print ": " . $self->$reader . "\n";
- }
- }
+ # print the attribute's value
+ my $reader = $attribute->get_read_method;
+ print ": " . $self->$reader . "\n";
+ }
+ }
Here's another example of using the attribute metaclass.
C<< $attribute->get_read_method >> returns the name of the method that can
Perl doesn't mind. Another way to write this would be
C<< $self->can($reader)->($self) >>. Yuck. :)
- package main;
- my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
- $app->dump;
+ package main;
+ my $app = MyApp::Website->new( url => "http://google.com", name => "Google" );
+ $app->dump;
And we wrap up the example with a script to show off our newfound magic.
a metaclass that expires attributes after a certain amount of time. You
might use it as such:
- has site_cache => (
- metaclass => 'TimedExpiry',
- expires_after => { hours => 1 },
- refresh_with => sub { get($_->url) },
- isa => 'Str',
- is => 'ro',
- );
+ has site_cache => (
+ metaclass => 'TimedExpiry',
+ expires_after => { hours => 1 },
+ refresh_with => sub { get( $_->url ) },
+ isa => 'Str',
+ is => 'ro',
+ );
The sky's the limit!
=head1 SYNOPSIS
- package MyApp::Meta::Attribute::Trait::Labeled;
- use Moose::Role;
-
- has label => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_label',
- );
-
- package Moose::Meta::Attribute::Custom::Trait::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
-
- package MyApp::Website;
- use Moose;
- use MyApp::Meta::Attribute::Trait::Labeled;
-
- has url => (
- traits => [qw/Labeled/],
- is => 'rw',
- isa => 'Str',
- label => "The site's URL",
- );
-
- has name => (
- is => 'rw',
- isa => 'Str',
- );
-
- sub dump {
- my $self = shift;
-
- # iterate over all the attributes in $self
- my %attributes = %{ $self->meta->get_attribute_map };
- while (my ($name, $attribute) = each %attributes) {
-
- # print the label if available
- if ($attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
- && $attribute->has_label) {
- print $attribute->label;
- }
- # otherwise print the name
- else {
- print $name;
- }
-
- # print the attribute's value
- my $reader = $attribute->get_read_method;
- print ": " . $self->$reader . "\n";
- }
- }
-
- package main;
- my $app = MyApp::Website->new(url => "http://google.com", name => "Google");
- $app->dump;
+ package MyApp::Meta::Attribute::Trait::Labeled;
+ use Moose::Role;
+
+ has label => (
+ is => 'rw',
+ isa => 'Str',
+ predicate => 'has_label',
+ );
+
+ package Moose::Meta::Attribute::Custom::Trait::Labeled;
+ sub register_implementation {'MyApp::Meta::Attribute::Trait::Labeled'}
+
+ package MyApp::Website;
+ use Moose;
+ use MyApp::Meta::Attribute::Trait::Labeled;
+
+ has url => (
+ traits => [qw/Labeled/],
+ is => 'rw',
+ isa => 'Str',
+ label => "The site's URL",
+ );
+
+ has name => (
+ is => 'rw',
+ isa => 'Str',
+ );
+
+ sub dump {
+ my $self = shift;
+
+ # iterate over all the attributes in $self
+ my %attributes = %{ $self->meta->get_attribute_map };
+ while ( my ( $name, $attribute ) = each %attributes ) {
+
+ # print the label if available
+ if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
+ && $attribute->has_label ) {
+ print $attribute->label;
+ }
+
+ # otherwise print the name
+ else {
+ print $name;
+ }
+
+ # print the attribute's value
+ my $reader = $attribute->get_read_method;
+ print ": " . $self->$reader . "\n";
+ }
+ }
+
+ package main;
+ my $app = MyApp::Website->new( url => "http://google.com", name => "Google" );
+ $app->dump;
=head1 BUT FIRST
indicate that defining and using a trait is very similar to defining and using
a new attribute metaclass.
- package MyApp::Meta::Attribute::Trait::Labeled;
- use Moose::Role;
+ package MyApp::Meta::Attribute::Trait::Labeled;
+ use Moose::Role;
- has label => (
- is => 'rw',
- isa => 'Str',
- predicate => 'has_label',
- );
+ has label => (
+ is => 'rw',
+ isa => 'Str',
+ predicate => 'has_label',
+ );
Instead of subclassing L<Moose::Meta::Attribute>, we define a role. Traits
don't need any special methods or attributes. You just focus on whatever it is
you actually need to get done. Here we're adding a new meta-attribute for use
in our application.
- package Moose::Meta::Attribute::Custom::Trait::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
+ package Moose::Meta::Attribute::Custom::Trait::Labeled;
+ sub register_implementation { 'MyApp::Meta::Attribute::Trait::Labeled' }
Much like when we define a new attribute metaclass, we can provide a shorthand
name for the trait. Moose looks at the C<register_implementation> method in
Now we begin writing our application logic. I'll only cover what has changed
since recipe 2.
- has url => (
- traits => [qw/Labeled/],
- is => 'rw',
- isa => 'Str',
- label => "The site's URL",
- );
+ has url => (
+ traits => [qw/Labeled/],
+ is => 'rw',
+ isa => 'Str',
+ label => "The site's URL",
+ );
L<Moose/has> provides a C<traits> option. Just pass the list of trait names and
it will compose them together to form the (anonymous) attribute metaclass used
by the attribute. We provide a label for the attribute in the same way.
- # print the label if available
- if ($attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
- && $attribute->has_label) {
- print $attribute->label;
- }
+ # print the label if available
+ if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
+ && $attribute->has_label ) {
+ print $attribute->label;
+ }
Previously, this code asked the question "Does this attribute use our attribute
metaclass?" Since we're now using a trait, we ask "Does this attribute's
easily get a regular metaclass extension out of it. You just compose the trait
in the attribute metaclass, as normal.
- package MyApp::Meta::Attribute::Labeled;
- use Moose;
- extends 'Moose::Meta::Attribute';
- with 'MyApp::Meta::Attribute::Trait::Labeled';
+ package MyApp::Meta::Attribute::Labeled;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
+ with 'MyApp::Meta::Attribute::Trait::Labeled';
- package Moose::Meta::Attribute::Custom::Labeled;
- sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
+ package Moose::Meta::Attribute::Custom::Labeled;
+ sub register_implementation { 'MyApp::Meta::Attribute::Labeled' }
Unfortunately, going the other way (providing a trait created from a metaclass)
is more tricky. Thus, defining your extensions as traits is just plain better
use Moose;
extends 'Moose::Meta::Class';
- has table =>
- ( is => 'rw',
- isa => 'Str',
- );
+ has table => (
+ is => 'rw',
+ isa => 'Str',
+ );
=head1 DESCRIPTION
Using this new "table" attribute is quite simple. Let's say we have a
class named C<MyApp::User>, we could simply write the following:
- my $table = MyApp::User->meta()->table();
+ my $table = MyApp::User->meta->table;
As long as MyApp::User has arranged to use C<MyApp::Meta::Class> as
its metaclass, this method call just works.
package MyApp::Meta::Class::Trait::HasTable;
use Moose::Role;
- has table =>
- ( is => 'rw',
- isa => 'Str',
- );
+ has table => (
+ is => 'rw',
+ isa => 'Str',
+ );
package Moose::Meta::Class::Custom::Trait::HasTable;
sub register_implementation { 'MyApp::Meta::Class::Trait::HasTable' }
Once this trait has been applied to a metaclass, it looks exactly like
the example we saw in L<Moose::Cookbook::Meta::Recipe4>:
- my $table = MyApp::User->meta()->table();
+ my $table = MyApp::User->meta->table;
=head1 SEE ALSO
package Eq;
use Moose::Role;
-
+
requires 'equal_to';
-
- sub not_equal_to {
- my ($self, $other) = @_;
+
+ sub not_equal_to {
+ my ( $self, $other ) = @_;
not $self->equal_to($other);
}
-
+
package Comparable;
use Moose::Role;
-
+
with 'Eq';
-
+
requires 'compare';
-
+
sub equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == 0;
- }
-
+ }
+
sub greater_than {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == 1;
- }
-
+ }
+
sub less_than {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == -1;
}
-
+
sub greater_than_or_equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->greater_than($other) || $self->equal_to($other);
- }
-
+ }
+
sub less_than_or_equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->less_than($other) || $self->equal_to($other);
- }
-
+ }
+
package Printable;
use Moose::Role;
-
- requires 'to_string';
-
+
+ requires 'to_string';
+
package US::Currency;
use Moose;
-
+
with 'Comparable', 'Printable';
-
- has 'amount' => (is => 'rw', isa => 'Num', default => 0);
-
+
+ has 'amount' => ( is => 'rw', isa => 'Num', default => 0 );
+
sub compare {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->amount <=> $other->amount;
}
-
+
sub to_string {
my $self = shift;
- sprintf '$%0.2f USD' => $self->amount
+ sprintf '$%0.2f USD' => $self->amount;
}
=head1 DESCRIPTION
target class need implement.
sub equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == 0;
}
-
+
sub greater_than {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == 1;
- }
-
+ }
+
sub less_than {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->compare($other) == -1;
}
-
+
sub greater_than_or_equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->greater_than($other) || $self->equal_to($other);
- }
-
+ }
+
sub less_than_or_equal_to {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->less_than($other) || $self->equal_to($other);
}
It also defines a regular Moose attribute, C<amount>, with a type constraint of
C<Num> and a default of C<0>:
- has 'amount' => (is => 'rw', isa => 'Num', default => 0);
+ has 'amount' => ( is => 'rw', isa => 'Num', default => 0 );
Now we come to the core of the class. First up, we define a C<compare> method:
sub compare {
- my ($self, $other) = @_;
+ my ( $self, $other ) = @_;
$self->amount <=> $other->amount;
}
sub to_string {
my $self = shift;
- sprintf '$%0.2f USD' => $self->amount
+ sprintf '$%0.2f USD' => $self->amount;
}
=head1 CONCLUSION
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=cut
+=cut
package Restartable::ButUnreliable;
use Moose::Role;
- with 'Restartable' => { alias => { stop => '_stop',
- start => '_start' } };
+ with 'Restartable' => {
+ alias => {
+ stop => '_stop',
+ start => '_start'
+ }
+ };
sub stop {
my $self = shift;
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed', 'weaken';
use overload ();
-our $VERSION = '0.63';
+our $VERSION = '0.64';
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Method::Accessor;
my @traits;
if (my $traits = $options{traits}) {
- if ( @traits = grep { not $class->does($_) } map {
- Moose::Util::resolve_metatrait_alias( Attribute => $_ )
- or
- $_
- } @$traits ) {
+ my $i = 0;
+ while ($i < @$traits) {
+ my $trait = $traits->[$i++];
+ next if ref($trait); # options to a trait we discarded
+
+ $trait = Moose::Util::resolve_metatrait_alias(Attribute => $trait)
+ || $trait;
+
+ next if $class->does($trait);
+
+ push @traits, $trait;
+
+ # are there options?
+ push @traits, $traits->[$i++]
+ if $traits->[$i] && ref($traits->[$i]);
+ }
+
+ if (@traits) {
my $anon_class = Moose::Meta::Class->create_anon_class(
superclasses => [ $class ],
roles => [ @traits ],
default coerce required
documentation lazy handles
builder type_constraint
+ definition_context
);
sub legal_options_for_inheritance { @legal_options_for_inheritance }
if ($self->should_coerce && $type_constraint->has_coercion) {
$val = $type_constraint->coerce($val);
}
- $type_constraint->check($val)
- || $self->throw_error("Attribute ("
- . $self->name
- . ") does not pass the type constraint because: "
- . $type_constraint->get_message($val), data => $val, object => $instance);
+ $self->verify_against_type_constraint($val, instance => $instance);
}
$self->set_initial_value($instance, $val);
if ($type_constraint) {
$val = $type_constraint->coerce($val)
if $can_coerce;
- $type_constraint->check($val)
- || $self->throw_error("Attribute ("
- . $slot_name
- . ") does not pass the type constraint because: "
- . $type_constraint->get_message($val), data => $val, object => $instance);
+ $self->verify_against_type_constraint($val, object => $instance);
}
$meta_instance->set_slot_value($instance, $slot_name, $val);
};
my $type_constraint = $self->type_constraint;
$value = $type_constraint->coerce($value)
if ($self->should_coerce);
- $type_constraint->check($value)
- || $self->throw_error("Attribute (" . $self->name
- . ") does not pass the type constraint because: "
- . $type_constraint->get_message($value), type_constraint => $type_constraint, data => $value);
+ $self->verify_against_type_constraint($value);
}
$self->set_initial_value($instance, $value);
}
}
elsif ($handle_type eq 'Regexp') {
($self->has_type_constraint)
- || $self->throw_error("Cannot delegate methods based on a RegExpr without a type constraint (isa)", data => $handles);
+ || $self->throw_error("Cannot delegate methods based on a Regexp without a type constraint (isa)", data => $handles);
return map { ($_ => $_) }
grep { /$handles/ } $self->_get_delegate_method_list;
}
);
}
+sub verify_against_type_constraint {
+ my $self = shift;
+ my $val = shift;
+
+ return 1 if !$self->has_type_constraint;
+
+ my $type_constraint = $self->type_constraint;
+
+ $type_constraint->check($val)
+ || $self->throw_error("Attribute ("
+ . $self->name
+ . ") does not pass the type constraint because: "
+ . $type_constraint->get_message($val), data => $val, @_);
+}
+
package Moose::Meta::Attribute::Custom::Moose;
sub register_implementation { 'Moose::Meta::Attribute' }
more information on what you can do with this, see the documentation
for L<Moose::Meta::TypeConstraint>.
+=item B<verify_against_type_constraint>
+
+Verifies that the given value is valid under this attribute's type
+constraint, otherwise throws an error.
+
=item B<has_handles>
Returns true if this meta-attribute performs delegation.
use List::MoreUtils qw( any all uniq );
use Scalar::Util 'weaken', 'blessed';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
# something like Super::Class|Super::Class::2=Role|Role::1
my $cache_key = join '=' => (
- join('|', sort @{$options{superclasses} || []}),
- join('|', sort @{$options{roles} || []}),
+ join('|', @{$options{superclasses} || []}),
+ join('|', sort @{$options{roles} || []}),
);
if ($cache_ok && defined $ANON_CLASSES{$cache_key}) {
my ($self, $attr_name, %options) = @_;
my $inherited_attr = $self->find_attribute_by_name($attr_name);
(defined $inherited_attr)
- || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from", data => $attr_name);
+ || $self->throw_error("Could not find an attribute by the name of '$attr_name' to inherit from in ${\$self->name}", data => $attr_name);
if ($inherited_attr->isa('Moose::Meta::Attribute')) {
return $inherited_attr->clone_and_inherit_options(%options);
}
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
};
#warn "code for $attr_name =>\n" . $code . "\n";
- my $sub = $self->_eval_closure($environment, $code);
- $self->throw_error("Could not create writer for '${\$self->associated_attribute->name}' because $@ \n code: $code", error => $@, data => $code ) if $@;
- return $sub;
-
+ $self->_eval_closure($environment, $self->_prepare_code( code => $code ) )
+ or $self->throw_error("Could not create writer for '${\$self->associated_attribute->name}' because $@ \n code: $code", error => $@, data => $code );
}
sub generate_accessor_method_inline {
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed', 'weaken', 'looks_like_number';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
our $AUTHORITY = 'cpan:STEVAN';
use base 'Moose::Meta::Method',
warn $source if $self->options->{debug};
my $code;
- my $attrs = $self->attributes;
- my @type_constraints = map {
- $_->can('type_constraint') ? $_->type_constraint : undef
- } @$attrs;
- my $environment = {
+ {
+ my $meta = $self; # FIXME for _inline_throw_error...
- # lexicals for the scope within which we will be constructed
-
- '$meta' => \$self, # FIXME for _inline_throw_error...
- '$attrs' => \$attrs,
+ # NOTE:
+ # create the nessecary lexicals
+ # to be picked up in the eval
+ my $attrs = $self->attributes;
# We need to check if the attribute ->can('type_constraint')
# since we may be trying to immutabilize a Moose meta class,
# because the inlined code is using the index of the attributes
# to determine where to find the type constraint
- '@type_constraints' => \@type_constraints,
+ my @type_constraints = map {
+ $_->can('type_constraint') ? $_->type_constraint : undef
+ } @$attrs;
- '@type_constraint_bodies' => [ map {
+ my @type_constraint_bodies = map {
defined $_ ? $_->_compiled_type_constraint : undef;
- } @type_constraints ]
- };
- $code = $self->_eval_closure($environment, $source);
- $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source ) if $@;
+ } @type_constraints;
+
+ $code = eval $source;
+ $self->throw_error("Could not eval the constructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source ) if $@;
+ }
$self->{'body'} = $code;
}
'$instance',
("'" . $attr->name . "'")
)
+ . ', '
+ . '$attrs->[' . $i . ']'
. ');'
."\n}"
);
use Carp 'confess';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed', 'weaken';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
$source .= ";\n" . '}';
warn $source if $self->options->{debug};
- my $code = $self->_eval_closure(q{}, $source);
- $self->throw_error("Could not eval the destructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source) if $@;
+ my $code;
+ {
+ $code = eval $source;
+ $self->throw_error("Could not eval the destructor :\n\n$source\n\nbecause :\n\n$@", error => $@, data => $source) if $@;
+ }
$self->{'body'} = $code;
}
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
# it is really more like body's compilation stash
# this is where we need to override the definition of super() so that the
# body of the code can call the right overridden version
- my $_super_package = $args{package} || $args{class}->name;
+ my $super_package = $args{package} || $args{class}->name;
my $name = $args{name};
my $method = $args{method};
my $body = sub {
+ local $Moose::SUPER_PACKAGE = $super_package;
local @Moose::SUPER_ARGS = @_;
local $Moose::SUPER_BODY = $super_body;
return $method->(@_);
};
# FIXME do we need this make sure this works for next::method?
- # subname "${_super_package}::${name}", $method;
+ # subname "${super_package}::${name}", $method;
# FIXME store additional attrs
$class->wrap(
use Scalar::Util 'blessed';
use Carp 'confess';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use warnings;
use metaclass;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Role::Composite;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Util 'english_list';
use Scalar::Util 'blessed';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::Attribute;
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use base qw(Class::MOP::Object);
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
=item B<parent>
-This type's parent type.
+This type's parent type.
=item B<has_parent>
=item B<parents>
+Synonym for C<parent>.
+
=item B<constraint>
+Returns this type's constraint. This is the value of C<where> provided
+when defining a type.
+
=item B<has_message>
+Returns true if this type has a message.
+
=item B<message>
+Returns this type's message.
+
=item B<get_message ($value)>
+Generate message for $value.
+
=item B<has_coercion>
+Returns true if this type has a coercion.
+
=item B<coercion>
+Returns this type's L<Moose::Meta::TypeCoercion> if one exists.
+
=item B<hand_optimized_type_constraint>
=item B<has_hand_optimized_type_constraint>
use Scalar::Util 'blessed';
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use warnings;
use metaclass;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Util::TypeConstraints;
use Moose::Meta::TypeConstraint::Parameterizable;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed';
use Carp 'confess'; # FIXME Moose->throw_error
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed';
use Moose::Util::TypeConstraints ();
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Meta::TypeCoercion::Union;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use if ( not our $__mx_is_compiled ), 'Moose::Meta::Class';
use if ( not our $__mx_is_compiled ), metaclass => 'Moose::Meta::Class';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Data::OptList;
use Sub::Exporter;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed';
use Class::MOP 0.60;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use strict;
use warnings;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
This utility module is designed to help authors of Moose extensions
write extensions that are able to cooperate with other Moose
extensions. To do this, you must write your extensions as roles, which
-can then be dynamically applyied to the caller's metaclasses.
+can then be dynamically applied to the caller's metaclasses.
This module makes sure to preserve any existing superclasses and roles
already set for the meta objects, which means that any number of
use Scalar::Util 'blessed';
use Moose::Exporter;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Scalar::Util 'blessed', 'looks_like_number';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Moose::Util 'does_role', 'find_meta';
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use Class::MOP;
-our $VERSION = '0.63';
+our $VERSION = '0.64';
$VERSION = eval $VERSION;
our $AUTHORITY = 'cpan:STEVAN';
use strict;
use warnings;
-use Test::More tests => 82;
+use Test::More tests => 83;
use Test::Exception;
::dies_ok {
has '+other_fail' => (weak_ref => 1);
} '... cannot create an attribute with an illegal option';
+ ::throws_ok {
+ has '+does_not_exist' => (isa => 'Str');
+ } qr/in Bar/, '... cannot extend a non-existing attribute';
}
my $foo = Foo->new;
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More tests => 4;
+
+{
+ package My::Attribute::Trait;
+ use Moose::Role;
+
+ sub reversed_name {
+ my $self = shift;
+ scalar reverse $self->name;
+ }
+}
+
+{
+ package My::Class;
+ use Moose;
+
+ has foo => (
+ traits => [
+ 'My::Attribute::Trait' => {
+ alias => {
+ reversed_name => 'eman',
+ },
+ },
+ ],
+ );
+}
+
+{
+ package My::Other::Class;
+ use Moose;
+
+ has foo => (
+ traits => [
+ 'My::Attribute::Trait' => {
+ alias => {
+ reversed_name => 'reversed',
+ },
+ },
+ ],
+ );
+}
+
+my $attr = My::Class->meta->get_attribute('foo');
+is($attr->eman, 'oof', 'the aliased method is in the attribute');
+ok(!$attr->can('reversed'), "the method was not installed under the other class' alias");
+
+my $other_attr = My::Other::Class->meta->get_attribute('foo');
+is($other_attr->reversed, 'oof', 'the aliased method is in the attribute');
+ok(!$other_attr->can('enam'), "the method was not installed under the other class' alias");
+
--- /dev/null
+#!/usr/bin/env perl
+use strict;
+use warnings;
+use Test::More skip_all => "Feature not implemented yet";
+#use Test::More tests => 1;
+
+{
+ package My::Trait;
+ use Moose::Role;
+
+ sub reversed_name {
+ my $self = shift;
+ scalar reverse $self->name;
+ }
+}
+
+{
+ package My::Class;
+ use Moose -traits => [
+ 'My::Trait' => {
+ alias => {
+ reversed_name => 'enam',
+ },
+ },
+ ];
+}
+
+is(My::Class->meta->enam, 'ssalC::yM', 'parameterized trait applied');
+
subtype 'FilePath'
=> as 'Str'
- => where { $_ =~ m#^(/[a-zA-Z0-9_.-]+)+$#
+ => where { $_ =~ m#^(/[a-zA-Z0-9_.-]+)+/?$#
|| $_ =~ m#^([c-zC-Z]:/[a-zA-Z0-9_.-]+)# };
{
package Baz;
--- /dev/null
+use strict;
+use warnings;
+
+use Test::More 'no_plan';
+
+{
+ package A;
+ use Moose;
+
+ sub foo {
+ ::BAIL_OUT('A::foo called twice') if $main::seen{'A::foo'}++;
+ return 'a';
+ }
+
+ sub bar {
+ ::BAIL_OUT('A::bar called twice') if $main::seen{'A::bar'}++;
+ return 'a';
+ }
+
+ sub baz {
+ ::BAIL_OUT('A::baz called twice') if $main::seen{'A::baz'}++;
+ return 'a';
+ }
+}
+
+{
+ package B;
+ use Moose;
+ extends qw(A);
+
+ sub foo {
+ ::BAIL_OUT('B::foo called twice') if $main::seen{'B::foo'}++;
+ return 'b' . super();
+ }
+
+ sub bar {
+ ::BAIL_OUT('B::bar called twice') if $main::seen{'B::bar'}++;
+ return 'b' . ( super() || '' );
+ }
+
+ override baz => sub {
+ ::BAIL_OUT('B::baz called twice') if $main::seen{'B::baz'}++;
+ return 'b' . super();
+ };
+}
+
+{
+ package C;
+ use Moose;
+ extends qw(B);
+
+ sub foo { return 'c' . ( super() || '' ) }
+
+ override bar => sub {
+ ::BAIL_OUT('C::bar called twice') if $main::seen{'C::bar'}++;
+ return 'c' . super();
+ };
+
+ override baz => sub {
+ ::BAIL_OUT('C::baz called twice') if $main::seen{'C::baz'}++;
+ return 'c' . super();
+ };
+}
+
+is( C->new->foo, 'c' );
+is( C->new->bar, 'cb' );
+is( C->new->baz, 'cba' );
--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+use Test::More;
+
+eval "use Test::Output";
+plan skip_all => "Test::Output is required for this test" if $@;
+
+plan tests => 1;
+
+{
+ package Foo;
+ use Moose;
+ __PACKAGE__->meta->make_immutable;
+}
+
+{
+ package Bar;
+ use Moose;
+
+ extends 'Foo';
+
+ __PACKAGE__->meta->make_immutable;
+ __PACKAGE__->meta->make_mutable;
+
+
+ # This actually is testing for a bug in Class::MOP that cause
+ # Moose::Meta::Method::Constructor to spit out a warning when it
+ # shouldn't have done so. The bug was fixed in CMOP 0.75.
+ ::stderr_unlike(
+ sub { Bar->meta->make_immutable },
+ qr/Not inlining a constructor/,
+ 'no warning that Bar may not have an inlined constructor'
+ );
+}
+
--- /dev/null
+#!/usr/bin/perl
+use strict;
+use warnings;
+
+BEGIN {
+ # attribute metaclass for specifying with 'has'
+ package Foo::Meta::Attribute;
+ use Moose;
+ extends 'Moose::Meta::Attribute';
+
+ around _process_options => sub {
+ my $orig = shift;
+ my ($class, $name, $opts) = @_;
+ my $default = delete $opts->{default};
+ $opts->{default} = sub { $default->() . "1" };
+ $class->$orig($name, $opts);
+ };
+
+ # trait for specifying with has
+ package Foo::Meta::Trait;
+ use Moose::Role;
+
+ around _process_options => sub {
+ my $orig = shift;
+ my ($class, $name, $opts) = @_;
+ my $default = delete $opts->{default};
+ $opts->{default} = sub { $default->() . "2" };
+ $class->$orig($name, $opts);
+ };
+
+ # attribute metaclass role for specifying with MetaRole
+ package Foo::Meta::Role::Attribute;
+ use Moose::Role;
+
+ around _process_options => sub {
+ my $orig = shift;
+ my ($class, $name, $opts) = @_;
+ my $default = delete $opts->{default};
+ $opts->{default} = sub { "3" . $default->() };
+ $class->$orig($name, $opts);
+ };
+
+ package Foose;
+ use Moose ();
+ use Moose::Exporter;
+ use Moose::Util::MetaRole;
+
+ Moose::Exporter->setup_import_methods(also => ['Moose']);
+
+ sub init_meta {
+ shift;
+ my %options = @_;
+ Moose->init_meta(%options);
+ Moose::Util::MetaRole::apply_metaclass_roles(
+ for_class => $options{for_class},
+ attribute_metaclass_roles => ['Foo::Meta::Role::Attribute'],
+ );
+ return $options{for_class}->meta;
+ }
+}
+
+# class that uses both
+{
+ package Foo;
+ BEGIN { Foose->import }
+
+ has bar => (
+ is => 'ro',
+ isa => 'Str',
+ lazy => 1,
+ default => sub { 'BAR' },
+ );
+
+ has baz => (
+ metaclass => 'Foo::Meta::Attribute',
+ is => 'ro',
+ isa => 'Str',
+ lazy => 1,
+ default => sub { 'BAZ' },
+ );
+
+ has quux => (
+ traits => ['Foo::Meta::Trait'],
+ is => 'ro',
+ isa => 'Str',
+ lazy => 1,
+ default => sub { 'QUUX' },
+ );
+}
+
+use Test::More tests => 8;
+my $foo = Foo->new;
+is($foo->bar, '3BAR', 'Attribute meta-role applied by exporter');
+ok($foo->meta->get_attribute('bar')->meta->does_role('Foo::Meta::Role::Attribute'), 'normal attribute does the meta-role');
+
+TODO: {
+ local $TODO = 'metaclass on attribute currently overrides attr metarole';
+ is($foo->baz, '3BAZ1', 'Attribute meta role from exporter + metaclass on attribute');
+ ok($foo->meta->get_attribute('baz')->meta->does_role('Foo::Meta::Role::Attribute'), 'attribute using metaclass does the meta-role');
+};
+ok($foo->meta->get_attribute('baz')->isa('Foo::Meta::Attribute'), 'attribute using a metaclass isa the metaclass');
+
+is($foo->quux, '3QUUX2', 'Attribute meta-role + trait');
+ok($foo->meta->get_attribute('quux')->meta->does_role('Foo::Meta::Role::Attribute'), 'attribute using a trait does the meta-role');
+ok($foo->meta->get_attribute('quux')->meta->does_role('Foo::Meta::Trait'), 'attribute using a trait does the trait');
projects / gitmo/Moose.git / commitdiff