From: Yuval Kogman Date: Sat, 17 Jan 2009 22:02:14 +0000 (+0000) Subject: Merge branch 'master' into method_generation_cleanup X-Git-Tag: 0.65~20^2~4 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=59f5bbde66d61d15b684be88d138fd798ba851d0;p=gitmo%2FMoose.git Merge branch 'master' into method_generation_cleanup Conflicts: Changes MANIFEST Makefile.PL README lib/Moose.pm lib/Moose/Error/Confess.pm lib/Moose/Error/Croak.pm lib/Moose/Error/Default.pm lib/Moose/Exporter.pm lib/Moose/Meta/Attribute.pm lib/Moose/Meta/Class.pm lib/Moose/Meta/Instance.pm lib/Moose/Meta/Method.pm lib/Moose/Meta/Method/Accessor.pm lib/Moose/Meta/Method/Augmented.pm lib/Moose/Meta/Method/Constructor.pm lib/Moose/Meta/Method/Delegation.pm lib/Moose/Meta/Method/Destructor.pm lib/Moose/Meta/Method/Overriden.pm lib/Moose/Meta/Role.pm lib/Moose/Meta/Role/Application.pm lib/Moose/Meta/Role/Application/RoleSummation.pm lib/Moose/Meta/Role/Application/ToClass.pm lib/Moose/Meta/Role/Application/ToInstance.pm lib/Moose/Meta/Role/Application/ToRole.pm lib/Moose/Meta/Role/Composite.pm lib/Moose/Meta/Role/Method.pm lib/Moose/Meta/Role/Method/Required.pm lib/Moose/Meta/TypeCoercion.pm lib/Moose/Meta/TypeCoercion/Union.pm lib/Moose/Meta/TypeConstraint.pm lib/Moose/Meta/TypeConstraint/Class.pm lib/Moose/Meta/TypeConstraint/Enum.pm lib/Moose/Meta/TypeConstraint/Parameterizable.pm lib/Moose/Meta/TypeConstraint/Parameterized.pm lib/Moose/Meta/TypeConstraint/Registry.pm lib/Moose/Meta/TypeConstraint/Role.pm lib/Moose/Meta/TypeConstraint/Union.pm lib/Moose/Object.pm lib/Moose/Role.pm lib/Moose/Util.pm lib/Moose/Util/MetaRole.pm lib/Moose/Util/TypeConstraints.pm lib/Moose/Util/TypeConstraints/OptimizedConstraints.pm lib/Test/Moose.pm lib/oose.pm --- diff --git a/Changes b/Changes index 5afd507..51cf345 100644 --- a/Changes +++ b/Changes @@ -1,8 +1,26 @@ 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 @@ -14,7 +32,7 @@ Revision history for Perl extension Moose - 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 @@ -1246,7 +1264,7 @@ Revision history for Perl extension Moose 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 diff --git a/MANIFEST b/MANIFEST index b1a2daf..ae7b365 100644 --- a/MANIFEST +++ b/MANIFEST @@ -139,6 +139,7 @@ t/020_attributes/020_trigger_and_coerce.t 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 @@ -215,6 +216,7 @@ t/050_metaclasses/016_metarole_w_metaclass_pm.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 @@ -255,6 +257,7 @@ t/300_immutable/009_buildargs.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 diff --git a/Makefile.PL b/Makefile.PL old mode 100644 new mode 100755 index 34efc5c..05a2cf2 --- a/Makefile.PL +++ b/Makefile.PL @@ -1,18 +1,19 @@ 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'; @@ -23,7 +24,6 @@ requires 'Filter::Simple' => '0'; # things the tests need build_requires 'Test::More' => '0.77'; build_requires 'Test::Exception' => '0.21'; -build_requires 'Test::LongString'; tests_recursive(); diff --git a/README b/README index e668f17..1d084cd 100644 --- a/README +++ b/README @@ -1,4 +1,4 @@ -Moose version 0.63 +Moose version 0.64 =========================== See the individual module documentation for more information diff --git a/lib/Moose.pm b/lib/Moose.pm index 43432c2..cae4f54 100644 --- a/lib/Moose.pm +++ b/lib/Moose.pm @@ -6,7 +6,7 @@ use warnings; use 5.008; -our $VERSION = '0.63'; +our $VERSION = '0.64'; $VERSION = eval $VERSION; our $AUTHORITY = 'cpan:STEVAN'; @@ -15,7 +15,7 @@ use Carp 'confess', 'croak', 'cluck'; use Moose::Exporter; -use Class::MOP 0.72; +use Class::MOP 0.75; use Moose::Meta::Class; use Moose::Meta::TypeConstraint; @@ -36,6 +36,13 @@ use Moose::Meta::Role::Application::ToInstance; 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; @@ -74,7 +81,7 @@ sub has { 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; } @@ -94,8 +101,15 @@ sub around { 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 { @@ -1116,6 +1130,8 @@ Piotr (dexter) Roszatycki Sam (mugwump) Vilain +Cory (gphat) Watson + ... and many other #moose folks =head1 COPYRIGHT AND LICENSE diff --git a/lib/Moose/Cookbook/Basics/Recipe10.pod b/lib/Moose/Cookbook/Basics/Recipe10.pod index d8bd36a..3b1fdf1 100644 --- a/lib/Moose/Cookbook/Basics/Recipe10.pod +++ b/lib/Moose/Cookbook/Basics/Recipe10.pod @@ -8,32 +8,33 @@ Moose::Cookbook::Basics::Recipe10 - Operator overloading, subtypes, and coercion =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, @@ -106,12 +107,12 @@ make classes for these genes. =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 @@ -122,12 +123,12 @@ which validates for the two possible colors. =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 @@ -142,31 +143,31 @@ won't get all cluttered up with the details behind the different 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 @@ -178,10 +179,16 @@ recessive to the brown bey gene and dominant to the blues. Finally, 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'; } @@ -202,16 +209,16 @@ create a new EyeColor that is derived in a similar manner as 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(), @@ -219,7 +226,7 @@ the gene selection in human reproduction. gey_2 => $two->$two_gey->color(), ); } - + sub _rand2 { return 1 + int( rand(2) ); } @@ -242,29 +249,28 @@ attribute called eye_color, and just for the sake of simple code 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 diff --git a/lib/Moose/Cookbook/Basics/Recipe2.pod b/lib/Moose/Cookbook/Basics/Recipe2.pod index 56d2909..152ebd8 100644 --- a/lib/Moose/Cookbook/Basics/Recipe2.pod +++ b/lib/Moose/Cookbook/Basics/Recipe2.pod @@ -9,33 +9,33 @@ Moose::Cookbook::Basics::Recipe2 - A simple B example 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); } @@ -45,11 +45,11 @@ Moose::Cookbook::Basics::Recipe2 - A simple B example 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, @@ -65,7 +65,7 @@ account. (1) The first class, B, 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 has a C attribute, which has a C type constraint, a read/write accessor, and a default value @@ -81,7 +81,7 @@ class's superclass. Here we see that B C B. 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 type constraint, which (as we saw in the first recipe) is a builtin type constraint. The @@ -101,9 +101,9 @@ In B, we see another method modifier, the C 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); } @@ -124,9 +124,9 @@ As with the method modifier in the first recipe, we could use C 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); } diff --git a/lib/Moose/Cookbook/Basics/Recipe3.pod b/lib/Moose/Cookbook/Basics/Recipe3.pod index 9782548..f92ae7b 100644 --- a/lib/Moose/Cookbook/Basics/Recipe3.pod +++ b/lib/Moose/Cookbook/Basics/Recipe3.pod @@ -9,35 +9,35 @@ Moose::Cookbook::Basics::Recipe3 - A lazy B example 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 @@ -55,7 +55,7 @@ and finally a C slot to hold a reference back up the tree. Now, let's start with the code. Our first attribute is the C 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 @@ -72,7 +72,7 @@ Next, let's move on to the C slot: has 'parent' => ( is => 'rw', - isa => 'BinaryTree', + isa => 'BinaryTree', predicate => 'has_parent', weak_ref => 1, ); @@ -100,11 +100,11 @@ Now, onto the C and C attributes. They are essentially identical, 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, C and C options do, but now we @@ -122,11 +122,11 @@ by value, this was all we had to say. But for any other item (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 slot. @@ -136,7 +136,7 @@ the subroutine is executed (to get the default value), we pass in the instance 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 instance for the C (or C) slot. Here we set up the correct relationship by passing @@ -173,10 +173,10 @@ the parental relationships that we need. We could write our own accessors, but 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 modifier, just like we saw in the second recipe, but with diff --git a/lib/Moose/Cookbook/Basics/Recipe5.pod b/lib/Moose/Cookbook/Basics/Recipe5.pod index 17fa51d..1526969 100644 --- a/lib/Moose/Cookbook/Basics/Recipe5.pod +++ b/lib/Moose/Cookbook/Basics/Recipe5.pod @@ -10,61 +10,61 @@ Moose::Cookbook::Basics::Recipe5 - More subtypes, coercion in a B class 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 -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 option. +This recipe introduces the idea of type coercions, and the C +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 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
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
subtype, which matches any instance of the class B: subtype 'Header' @@ -74,60 +74,60 @@ class B: 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. This is nice, but it is not +We would then have a self-validating accessor whose default value is +an empty instance of B. This is nice, but it is not ideal. The constructor for B 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 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 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 clauses which map other -subtypes to coercion routines (through the C 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 clauses which map other +subtypes to coercion routines (through the C 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 or B which is passed into the C accessor into an instance of B. 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 module, which fits in rather nicely with L. -Again, we create a simple subtype to represent instances of the -B class: +Again, we create a simple subtype to represent instances of the B +class: subtype 'Uri' => as 'Object' @@ -137,50 +137,50 @@ Then we add the coercion: 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 clause we introduce is for the 'Object' subtype. An 'Object' -is simply any Ced value. This means that if the coercion encounters -another object, it should use this clause. Now we look at the C block. -First it checks to see if the object is a B 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, then we need to coerce -it. This is where L 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 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 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 clause we introduce is for the 'Object' subtype. An +'Object' is simply any Ced value. This means that if the +coercion encounters another object, it should use this clause. Now we +look at the C block. First it checks to see if the object is a +B 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, then we need to +coerce it. This is where L 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 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 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 diff --git a/lib/Moose/Cookbook/Basics/Recipe7.pod b/lib/Moose/Cookbook/Basics/Recipe7.pod index fdb0f1c..eda3c63 100644 --- a/lib/Moose/Cookbook/Basics/Recipe7.pod +++ b/lib/Moose/Cookbook/Basics/Recipe7.pod @@ -10,8 +10,8 @@ Moose::Cookbook::Basics::Recipe7 - Making Moose fast with immutable 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; diff --git a/lib/Moose/Cookbook/Extending/Recipe1.pod b/lib/Moose/Cookbook/Extending/Recipe1.pod index e94fc01..d79d9d7 100644 --- a/lib/Moose/Cookbook/Extending/Recipe1.pod +++ b/lib/Moose/Cookbook/Extending/Recipe1.pod @@ -139,10 +139,10 @@ metaclass and attribute metaclass traits: 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. @@ -185,7 +185,7 @@ subclasses: 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( @@ -217,13 +217,13 @@ extension can easily use it with other role-based extensions. 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); diff --git a/lib/Moose/Cookbook/Extending/Recipe2.pod b/lib/Moose/Cookbook/Extending/Recipe2.pod index 0bdeae5..f165e26 100644 --- a/lib/Moose/Cookbook/Extending/Recipe2.pod +++ b/lib/Moose/Cookbook/Extending/Recipe2.pod @@ -12,6 +12,7 @@ Moose::Cookbook::Extending::Recipe2 - Providing a role for the base object class use strict; use warnings; + use Moose (); use Moose::Exporter; use Moose::Util::MetaRole; use MooseX::Debugging::Role::Object; @@ -22,20 +23,21 @@ Moose::Cookbook::Extending::Recipe2 - Providing a role for the base object class 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 diff --git a/lib/Moose/Cookbook/Meta/Recipe2.pod b/lib/Moose/Cookbook/Meta/Recipe2.pod index d5f3754..791d90a 100644 --- a/lib/Moose/Cookbook/Meta/Recipe2.pod +++ b/lib/Moose/Cookbook/Meta/Recipe2.pod @@ -7,61 +7,62 @@ Moose::Cookbook::Meta::Recipe2 - A meta-attribute, attributes with labels =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 @@ -81,8 +82,8 @@ All the attributes of a Moose-based object are actually objects themselves. 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 @@ -94,23 +95,23 @@ and forget that there's a lot of machinery lying in such methods. So you have a C<$point> object, which has C and C 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 returns a hash reference that maps attribute names to their objects. In our case, C 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) @@ -134,18 +135,18 @@ Let's start dissecting the recipe's code. 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. @@ -156,8 +157,8 @@ The name is "label", it will have a regular accessor, and is a string. C is a standard part of C. 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. @@ -165,19 +166,19 @@ 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, to C. C lets you set the metaclass of the attribute. @@ -199,35 +200,35 @@ your own namespaces. Finally, we see that C is setting our new meta-attribute, C