From: Stevan Little Date: Sat, 25 Mar 2006 02:22:23 +0000 (+0000) Subject: cookbook X-Git-Tag: 0_05~61 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=471c4f0999c20c70c19433519b2200171703cc6c;p=gitmo%2FMoose.git cookbook --- diff --git a/Changes b/Changes index bd068e0..0ad2c39 100644 --- a/Changes +++ b/Changes @@ -13,6 +13,10 @@ Revision history for Perl extension Moose - BUILDALL now takes a reference of the %params that are passed to &new, and passes that to each BUILD as well. + + * Moose::Util::TypeConstraints + - Type constraints now survive runtime reloading + - added test for this * Moose::Meta::Class - fixed the way attribute defaults are handled diff --git a/lib/Moose/Cookbook.pod b/lib/Moose/Cookbook.pod new file mode 100644 index 0000000..4242967 --- /dev/null +++ b/lib/Moose/Cookbook.pod @@ -0,0 +1,52 @@ + +=pod + +=head1 NAME + +Moose::Cookbook - How to cook a Moose + +=head1 DESCRIPTION + +The Moose cookbook is a series of recipies taken from the Moose +test suite. Each recipe presents some code, which demonstrates +some of the features of Moose, and then proceeds to explain the +details of the code. + +=head1 RECIPES + +=over 4 + +=item L + +=item L + +=item L + +=item L + +=item L + +=back + +=head1 SEE ALSO + +=over 4 + +=item L + +=back + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/Moose/Cookbook/Recipe1.pod b/lib/Moose/Cookbook/Recipe1.pod new file mode 100644 index 0000000..2c84868 --- /dev/null +++ b/lib/Moose/Cookbook/Recipe1.pod @@ -0,0 +1,53 @@ + +=pod + +=head1 NAME + +Moose::Cookbook::Recipe1 + +=head1 SYNOPSIS + + package Point; + use strict; + use warnings; + use Moose; + + has 'x' => (isa => 'Int', is => 'ro'); + has 'y' => (isa => 'Int', is => 'rw'); + + sub clear { + my $self = shift; + $self->{x} = 0; + $self->y(0); + } + + package Point3D; + use strict; + use warnings; + use Moose; + + extends 'Point'; + + has 'z' => (isa => 'Int'); + + after 'clear' => sub { + my $self = shift; + $self->{z} = 0; + }; + +=head1 DESCRIPTION + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/Moose/Cookbook/Recipe2.pod b/lib/Moose/Cookbook/Recipe2.pod new file mode 100644 index 0000000..ce8ca3b --- /dev/null +++ b/lib/Moose/Cookbook/Recipe2.pod @@ -0,0 +1,63 @@ + +=pod + +=head1 NAME + +Moose::Cookbook::Recipe2 + +=head1 SYNOPSIS + + package BankAccount; + use strict; + use warnings; + use Moose; + + has 'balance' => (isa => 'Int', is => 'rw', default => 0); + + sub deposit { + my ($self, $amount) = @_; + $self->balance($self->balance + $amount); + } + + sub withdraw { + my ($self, $amount) = @_; + my $current_balance = $self->balance(); + ($current_balance >= $amount) + || confess "Account overdrawn"; + $self->balance($current_balance - $amount); + } + + package CheckingAccount; + use strict; + use warnings; + use Moose; + + extends 'BankAccount'; + + has 'overdraft_account' => (isa => 'BankAccount', is => 'rw'); + + before 'withdraw' => sub { + my ($self, $amount) = @_; + my $overdraft_amount = $amount - $self->balance(); + if ($overdraft_amount > 0) { + $self->overdraft_account->withdraw($overdraft_amount); + $self->deposit($overdraft_amount); + } + }; + +=head1 DESCRIPTION + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/Moose/Cookbook/Recipe3.pod b/lib/Moose/Cookbook/Recipe3.pod new file mode 100644 index 0000000..5ddd267 --- /dev/null +++ b/lib/Moose/Cookbook/Recipe3.pod @@ -0,0 +1,54 @@ + +=pod + +=head1 NAME + +Moose::Cookbook::Recipe3 + +=head1 SYNOPSIS + + package BinaryTree; + use strict; + use warnings; + use Moose; + + has 'parent' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_parent', + weak_ref => 1, + ); + + has 'left' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_left', + ); + + has 'right' => ( + is => 'rw', + isa => 'BinaryTree', + predicate => 'has_right', + ); + + before 'right', 'left' => sub { + my ($self, $tree) = @_; + $tree->parent($self) if defined $tree; + }; + +=head1 DESCRIPTION + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/Moose/Cookbook/Recipe4.pod b/lib/Moose/Cookbook/Recipe4.pod new file mode 100644 index 0000000..9bef18b --- /dev/null +++ b/lib/Moose/Cookbook/Recipe4.pod @@ -0,0 +1,106 @@ + +=pod + +=head1 NAME + +Moose::Cookbook::Recipe4 + +=head1 SYNOPSIS + + package Address; + use strict; + use warnings; + use Moose; + + use Locale::US; + use Regexp::Common 'zip'; + + my $STATES = Locale::US->new; + + subtype USState + => as Str + => where { + (exists $STATES->{code2state}{uc($_)} || exists $STATES->{state2code}{uc($_)}) + }; + + subtype USZipCode + => as Value + => where { + /^$RE{zip}{US}{-extended => 'allow'}$/ + }; + + has 'street' => (is => 'rw', isa => 'Str'); + has 'city' => (is => 'rw', isa => 'Str'); + has 'state' => (is => 'rw', isa => 'USState'); + has 'zip_code' => (is => 'rw', isa => 'USZipCode'); + + package Company; + use strict; + use warnings; + use Moose; + + has 'name' => (is => 'rw', isa => 'Str'); + has 'address' => (is => 'rw', isa => 'Address'); + has 'employees' => (is => 'rw', isa => subtype ArrayRef => where { + ($_->isa('Employee') || return) for @$_; 1 + }); + + sub BUILD { + my ($self, $params) = @_; + if ($params->{employees}) { + foreach my $employee (@{$params->{employees}}) { + $employee->company($self); + } + } + } + + sub get_employee_count { scalar @{(shift)->employees} } + + package Person; + use strict; + use warnings; + use Moose; + + has 'first_name' => (is => 'rw', isa => 'Str'); + has 'last_name' => (is => 'rw', isa => 'Str'); + has 'middle_initial' => (is => 'rw', isa => 'Str', predicate => 'has_middle_initial'); + has 'address' => (is => 'rw', isa => 'Address'); + + sub full_name { + my $self = shift; + return $self->first_name . + ($self->has_middle_initial ? ' ' . $self->middle_initial . '. ' : ' ') . + $self->last_name; + } + + package Employee; + use strict; + use warnings; + use Moose; + + extends 'Person'; + + has 'title' => (is => 'rw', isa => 'Str'); + has 'company' => (is => 'rw', isa => 'Company', weak_ref => 1); + + override 'full_name' => sub { + my $self = shift; + super() . ', ' . $self->title + }; + +=head1 DESCRIPTION + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/lib/Moose/Cookbook/Recipe5.pod b/lib/Moose/Cookbook/Recipe5.pod new file mode 100644 index 0000000..6bc325d --- /dev/null +++ b/lib/Moose/Cookbook/Recipe5.pod @@ -0,0 +1,70 @@ + +=pod + +=head1 NAME + +Moose::Cookbook::Recipe5 + +=head1 SYNOPSIS + + package Request; + use strict; + use warnings; + use Moose; + + use HTTP::Headers (); + use Params::Coerce (); + use URI (); + + subtype Header + => as Object + => where { $_->isa('HTTP::Headers') }; + + coerce Header + => from ArrayRef + => via { HTTP::Headers->new( @{ $_ } ) } + => from HashRef + => via { HTTP::Headers->new( %{ $_ } ) }; + + subtype Uri + => as Object + => where { $_->isa('URI') }; + + coerce Uri + => from Object + => via { $_->isa('URI') ? $_ : Params::Coerce::coerce( 'URI', $_ ) } + => from Str + => via { URI->new( $_, 'http' ) }; + + subtype Protocol + => as Str + => where { /^HTTP\/[0-9]\.[0-9]$/ }; + + + has 'base' => (is => 'rw', isa => 'Uri', coerce => 1); + has 'url' => (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 } + ); + +=head1 DESCRIPTION + +=head1 AUTHOR + +Stevan Little Estevan@iinteractive.comE + +=head1 COPYRIGHT AND LICENSE + +Copyright 2006 by Infinity Interactive, Inc. + +L + +This library is free software; you can redistribute it and/or modify +it under the same terms as Perl itself. + +=cut \ No newline at end of file diff --git a/t/005_basic.t b/t/005_basic.t index 9321766..726f211 100644 --- a/t/005_basic.t +++ b/t/005_basic.t @@ -3,116 +3,115 @@ use strict; use warnings; -use Test::More tests => 26; -use Test::Exception; +use Test::More; BEGIN { - use_ok('Moose'); + eval "use HTTP::Headers; use Params::Coerce; use URI;"; + plan skip_all => "HTTP::Headers & Params::Coerce & URI required for this test" if $@; + plan no_plan => 1; } -{ - package HTTPHeader; - use strict; - use warnings; - use Moose; - - coerce 'HTTPHeader' - => from ArrayRef - => via { HTTPHeader->new(array => $_[0]) } - => from HashRef - => via { HTTPHeader->new(hash => $_[0]) }; - - has 'array' => (is => 'ro'); - has 'hash' => (is => 'ro'); +use Test::Exception; - package Engine; - use strict; - use warnings; - use Moose; - - has 'header' => (is => 'rw', isa => 'HTTPHeader', coerce => 1); +BEGIN { + use_ok('Moose'); } { - my $engine = Engine->new(); - isa_ok($engine, 'Engine'); - - # try with arrays - - lives_ok { - $engine->header([ 1, 2, 3 ]); - } '... type was coerced without incident'; - isa_ok($engine->header, 'HTTPHeader'); - - is_deeply( - $engine->header->array, - [ 1, 2, 3 ], - '... got the right array value of the header'); - ok(!defined($engine->header->hash), '... no hash value set'); - - # try with hash + package Request; + use strict; + use warnings; + use Moose; + + use HTTP::Headers (); + use Params::Coerce (); + use URI (); + + subtype Header + => as Object + => where { $_->isa('HTTP::Headers') }; + + coerce Header + => from ArrayRef + => via { HTTP::Headers->new( @{ $_ } ) } + => from HashRef + => via { HTTP::Headers->new( %{ $_ } ) }; + + subtype Uri + => as Object + => where { $_->isa('URI') }; + + coerce Uri + => from Object + => via { $_->isa('URI') ? $_ : Params::Coerce::coerce( 'URI', $_ ) } + => from Str + => via { URI->new( $_, 'http' ) }; + + subtype Protocol + => as Str + => where { /^HTTP\/[0-9]\.[0-9]$/ }; + + + has 'base' => (is => 'rw', isa => 'Uri', coerce => 1); + has 'url' => (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 } + ); +} - lives_ok { - $engine->header({ one => 1, two => 2, three => 3 }); - } '... type was coerced without incident'; - isa_ok($engine->header, 'HTTPHeader'); +my $r = Request->new; +isa_ok($r, 'Request'); - is_deeply( - $engine->header->hash, - { one => 1, two => 2, three => 3 }, - '... got the right hash value of the header'); - ok(!defined($engine->header->array), '... no array value set'); +{ + my $header = $r->headers; + isa_ok($header, 'HTTP::Headers'); - dies_ok { - $engine->header("Foo"); - } '... dies with the wrong type, even after coercion'; + is($r->headers->content_type, '', '... got no content type in the header'); - lives_ok { - $engine->header(HTTPHeader->new); - } '... lives with the right type, even after coercion'; -} + $r->headers( { content_type => 'text/plain' } ); -{ - my $engine = Engine->new(header => [ 1, 2, 3 ]); - isa_ok($engine, 'Engine'); + my $header2 = $r->headers; + isa_ok($header2, 'HTTP::Headers'); + isnt($header, $header2, '... created a new HTTP::Header object'); - isa_ok($engine->header, 'HTTPHeader'); + is($header2->content_type, 'text/plain', '... got the right content type in the header'); - is_deeply( - $engine->header->array, - [ 1, 2, 3 ], - '... got the right array value of the header'); - ok(!defined($engine->header->hash), '... no hash value set'); -} + $r->headers( [ content_type => 'text/html' ] ); -{ - my $engine = Engine->new(header => { one => 1, two => 2, three => 3 }); - isa_ok($engine, 'Engine'); + my $header3 = $r->headers; + isa_ok($header3, 'HTTP::Headers'); + isnt($header2, $header3, '... created a new HTTP::Header object'); - isa_ok($engine->header, 'HTTPHeader'); + is($header3->content_type, 'text/html', '... got the right content type in the header'); + + $r->headers( HTTP::Headers->new(content_type => 'application/pdf') ); + + my $header4 = $r->headers; + isa_ok($header4, 'HTTP::Headers'); + isnt($header3, $header4, '... created a new HTTP::Header object'); - is_deeply( - $engine->header->hash, - { one => 1, two => 2, three => 3 }, - '... got the right hash value of the header'); - ok(!defined($engine->header->array), '... no array value set'); + is($header4->content_type, 'application/pdf', '... got the right content type in the header'); + + dies_ok { + $r->headers('Foo') + } '... dies when it gets bad params'; } { - my $engine = Engine->new(header => HTTPHeader->new()); - isa_ok($engine, 'Engine'); - - isa_ok($engine->header, 'HTTPHeader'); + is($r->protocol, undef, '... got nothing by default'); - ok(!defined($engine->header->hash), '... no hash value set'); - ok(!defined($engine->header->array), '... no array value set'); + lives_ok { + $r->protocol('HTTP/1.0'); + } '... set the protocol correctly'; + is($r->protocol, 'HTTP/1.0', '... got nothing by default'); + + dies_ok { + $r->protocol('http/1.0'); + } '... the protocol died with bar params correctly'; } -dies_ok { - Engine->new(header => 'Foo'); -} '... dies correctly with bad params'; - -dies_ok { - Engine->new(header => \(my $var)); -} '... dies correctly with bad params'; - diff --git a/t/006_basic.t b/t/006_basic.t index 726f211..d02f46c 100644 --- a/t/006_basic.t +++ b/t/006_basic.t @@ -3,115 +3,9 @@ use strict; use warnings; -use Test::More; - -BEGIN { - eval "use HTTP::Headers; use Params::Coerce; use URI;"; - plan skip_all => "HTTP::Headers & Params::Coerce & URI required for this test" if $@; - plan no_plan => 1; -} - +use Test::More tests => 1; use Test::Exception; BEGIN { use_ok('Moose'); } - -{ - package Request; - use strict; - use warnings; - use Moose; - - use HTTP::Headers (); - use Params::Coerce (); - use URI (); - - subtype Header - => as Object - => where { $_->isa('HTTP::Headers') }; - - coerce Header - => from ArrayRef - => via { HTTP::Headers->new( @{ $_ } ) } - => from HashRef - => via { HTTP::Headers->new( %{ $_ } ) }; - - subtype Uri - => as Object - => where { $_->isa('URI') }; - - coerce Uri - => from Object - => via { $_->isa('URI') ? $_ : Params::Coerce::coerce( 'URI', $_ ) } - => from Str - => via { URI->new( $_, 'http' ) }; - - subtype Protocol - => as Str - => where { /^HTTP\/[0-9]\.[0-9]$/ }; - - - has 'base' => (is => 'rw', isa => 'Uri', coerce => 1); - has 'url' => (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 } - ); -} - -my $r = Request->new; -isa_ok($r, 'Request'); - -{ - my $header = $r->headers; - isa_ok($header, 'HTTP::Headers'); - - is($r->headers->content_type, '', '... got no content type in the header'); - - $r->headers( { content_type => 'text/plain' } ); - - my $header2 = $r->headers; - isa_ok($header2, 'HTTP::Headers'); - isnt($header, $header2, '... created a new HTTP::Header object'); - - is($header2->content_type, 'text/plain', '... got the right content type in the header'); - - $r->headers( [ content_type => 'text/html' ] ); - - my $header3 = $r->headers; - isa_ok($header3, 'HTTP::Headers'); - isnt($header2, $header3, '... created a new HTTP::Header object'); - - is($header3->content_type, 'text/html', '... got the right content type in the header'); - - $r->headers( HTTP::Headers->new(content_type => 'application/pdf') ); - - my $header4 = $r->headers; - isa_ok($header4, 'HTTP::Headers'); - isnt($header3, $header4, '... created a new HTTP::Header object'); - - is($header4->content_type, 'application/pdf', '... got the right content type in the header'); - - dies_ok { - $r->headers('Foo') - } '... dies when it gets bad params'; -} - -{ - is($r->protocol, undef, '... got nothing by default'); - - lives_ok { - $r->protocol('HTTP/1.0'); - } '... set the protocol correctly'; - is($r->protocol, 'HTTP/1.0', '... got nothing by default'); - - dies_ok { - $r->protocol('http/1.0'); - } '... the protocol died with bar params correctly'; -} - diff --git a/t/056_util_more_type_coercion.t b/t/056_util_more_type_coercion.t new file mode 100644 index 0000000..9321766 --- /dev/null +++ b/t/056_util_more_type_coercion.t @@ -0,0 +1,118 @@ +#!/usr/bin/perl + +use strict; +use warnings; + +use Test::More tests => 26; +use Test::Exception; + +BEGIN { + use_ok('Moose'); +} + +{ + package HTTPHeader; + use strict; + use warnings; + use Moose; + + coerce 'HTTPHeader' + => from ArrayRef + => via { HTTPHeader->new(array => $_[0]) } + => from HashRef + => via { HTTPHeader->new(hash => $_[0]) }; + + has 'array' => (is => 'ro'); + has 'hash' => (is => 'ro'); + + package Engine; + use strict; + use warnings; + use Moose; + + has 'header' => (is => 'rw', isa => 'HTTPHeader', coerce => 1); +} + +{ + my $engine = Engine->new(); + isa_ok($engine, 'Engine'); + + # try with arrays + + lives_ok { + $engine->header([ 1, 2, 3 ]); + } '... type was coerced without incident'; + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->array, + [ 1, 2, 3 ], + '... got the right array value of the header'); + ok(!defined($engine->header->hash), '... no hash value set'); + + # try with hash + + lives_ok { + $engine->header({ one => 1, two => 2, three => 3 }); + } '... type was coerced without incident'; + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->hash, + { one => 1, two => 2, three => 3 }, + '... got the right hash value of the header'); + ok(!defined($engine->header->array), '... no array value set'); + + dies_ok { + $engine->header("Foo"); + } '... dies with the wrong type, even after coercion'; + + lives_ok { + $engine->header(HTTPHeader->new); + } '... lives with the right type, even after coercion'; +} + +{ + my $engine = Engine->new(header => [ 1, 2, 3 ]); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->array, + [ 1, 2, 3 ], + '... got the right array value of the header'); + ok(!defined($engine->header->hash), '... no hash value set'); +} + +{ + my $engine = Engine->new(header => { one => 1, two => 2, three => 3 }); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + is_deeply( + $engine->header->hash, + { one => 1, two => 2, three => 3 }, + '... got the right hash value of the header'); + ok(!defined($engine->header->array), '... no array value set'); +} + +{ + my $engine = Engine->new(header => HTTPHeader->new()); + isa_ok($engine, 'Engine'); + + isa_ok($engine->header, 'HTTPHeader'); + + ok(!defined($engine->header->hash), '... no hash value set'); + ok(!defined($engine->header->array), '... no array value set'); +} + +dies_ok { + Engine->new(header => 'Foo'); +} '... dies correctly with bad params'; + +dies_ok { + Engine->new(header => \(my $var)); +} '... dies correctly with bad params'; +