- 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
--- /dev/null
+
+=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<Moose::Cookbook::Recipe1>
+
+=item L<Moose::Cookbook::Recipe2>
+
+=item L<Moose::Cookbook::Recipe3>
+
+=item L<Moose::Cookbook::Recipe4>
+
+=item L<Moose::Cookbook::Recipe5>
+
+=back
+
+=head1 SEE ALSO
+
+=over 4
+
+=item L<http://www.gsph.com/gsph/index.php?ID=291&Lang=En>
+
+=back
+
+=head1 AUTHOR
+
+Stevan Little E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
\ No newline at end of file
--- /dev/null
+
+=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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
\ No newline at end of file
--- /dev/null
+
+=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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
\ No newline at end of file
--- /dev/null
+
+=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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
\ No newline at end of file
--- /dev/null
+
+=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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
\ No newline at end of file
--- /dev/null
+
+=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 E<lt>stevan@iinteractive.comE<gt>
+
+=head1 COPYRIGHT AND LICENSE
+
+Copyright 2006 by Infinity Interactive, Inc.
+
+L<http://www.iinteractive.com>
+
+This library is free software; you can redistribute it and/or modify
+it under the same terms as Perl itself.
+
+=cut
\ No newline at end of file
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';
-
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';
-}
-
--- /dev/null
+#!/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';
+
projects / gitmo/Moose.git / commitdiff