--- /dev/null
+#!/usr/bin/perl
+
+use strict;
+use warnings;
+
+{
+ package My::Extract;
+
+ use base 'Test::Inline::Extract';
+
+ # This extracts the SYNOPSIS in addition to code specifically
+ # marked for testing
+ my $search = qr/
+ (?:^|\n) # After the beginning of the string, or a newline
+ ( # ... start capturing
+ # EITHER
+ package\s+ # A package
+ [^\W\d]\w*(?:(?:\'|::)[^\W\d]\w*)* # ... with a name
+ \s*; # And a statement terminator
+ |
+ =head1[ \t]+SYNOPSIS\n
+ .*?
+ (?=\n=)
+ | # OR
+ =for[ \t]+example[ \t]+begin\n # ... when we find a =for example begin
+ .*? # ... and keep capturing
+ \n=for[ \t]+example[ \t]+end\s*? # ... until the =for example end
+ (?:\n|$) # ... at the end of file or a newline
+ | # OR
+ =begin[ \t]+(?:test|testing)\b # ... when we find a =begin test or testing
+ .*? # ... and keep capturing
+ \n=end[ \t]+(?:test|testing)\s*? # ... until an =end tag
+ (?:\n|$) # ... at the end of file or a newline
+ ) # ... and stop capturing
+ /isx;
+
+ sub _elements {
+ my $self = shift;
+ my @elements = ();
+ while ( $self->{source} =~ m/$search/go ) {
+ my $elt = $1;
+
+ # A hack to turn the SYNOPSIS into something Test::Inline
+ # doesn't barf on
+ if ( $elt =~ s/=head1[ \t]+SYNOPSIS/=begin testing SETUP\n\n{/ ) {
+ $elt .= "}\n\n=end testing SETUP";
+ }
+
+ push @elements, $elt;
+ }
+
+ # If we have just one element it's a SYNOPSIS, so there's no
+ # tests.
+ return unless @elements > 1;
+
+ if ( @elements && $self->{source} =~ /=head1 NAME\n\n(Moose::Cookbook\S+)/ ) {
+ unshift @elements, 'package ' . $1 . ';';
+ }
+
+ (List::Util::first { /^=/ } @elements) ? \@elements : '';
+ }
+}
+
+{
+ package My::Content;
+
+ use base 'Test::Inline::Content::Default';
+
+ sub process {
+ my $self = shift;
+
+ my $base = $self->SUPER::process(@_);
+
+ $base =~ s/(\$\| = 1;)/use Test::Exception;\n$1/;
+
+ return $base;
+ }
+}
+
+use File::Find::Rule;
+use Test::Inline;
+
+
+my $target = 't/000_recipes';
+
+for my $t_file ( File::Find::Rule->file->name(qr/\.t$/)->in($target) ) {
+ unlink $t_file or die "Cannot unlink $t_file: $!";
+}
+
+my $inline = Test::Inline->new(
+ verbose => 1,
+ readonly => 1,
+ output => $target,
+ ExtractHandler => 'My::Extract',
+ ContentHandler => 'My::Content',
+);
+
+for my $pod (
+ File::Find::Rule->file->name(qr/\.pod$/)->in('lib/Moose/Cookbook') ) {
+ $inline->add($pod);
+}
+
+$inline->save;
$self->z(0);
};
- ....
+ package main;
# hash or hashrefs are ok for the constructor
my $point1 = Point->new(x => 5, y => 7);
From here on, we can use C<$point> and C<$point3d> just as you would
any other Perl 5 object. For a more detailed example of what can be
-done, you can refer to the F<t/000_recipes/basic/001_point.t> test
-file.
+done, you can refer to the
+F<t/000_recipes/moose_cookbook_basics_recipe1.t> test file.
=head2 Moose Objects are Just Hashrefs
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+my $point = Point->new( x => 1, y => 2 );
+isa_ok( $point, 'Point' );
+isa_ok( $point, 'Moose::Object' );
+
+is( $point->x, 1, '... got the right value for x' );
+is( $point->y, 2, '... got the right value for y' );
+
+$point->y(10);
+is( $point->y, 10, '... got the right (changed) value for y' );
+
+dies_ok {
+ $point->y('Foo');
+}
+'... cannot assign a non-Int to y';
+
+dies_ok {
+ Point->new();
+}
+'... must provide required attributes to new';
+
+$point->clear();
+
+is( $point->x, 0, '... got the right (cleared) value for x' );
+is( $point->y, 0, '... got the right (cleared) value for y' );
+
+# check the type constraints on the constructor
+
+lives_ok {
+ Point->new( x => 0, y => 0 );
+}
+'... can assign a 0 to x and y';
+
+dies_ok {
+ Point->new( x => 10, y => 'Foo' );
+}
+'... cannot assign a non-Int to y';
+
+dies_ok {
+ Point->new( x => 'Foo', y => 10 );
+}
+'... cannot assign a non-Int to x';
+
+# Point3D
+
+my $point3d = Point3D->new( { x => 10, y => 15, z => 3 } );
+isa_ok( $point3d, 'Point3D' );
+isa_ok( $point3d, 'Point' );
+isa_ok( $point3d, 'Moose::Object' );
+
+is( $point3d->x, 10, '... got the right value for x' );
+is( $point3d->y, 15, '... got the right value for y' );
+is( $point3d->{'z'}, 3, '... got the right value for z' );
+
+$point3d->clear();
+
+is( $point3d->x, 0, '... got the right (cleared) value for x' );
+is( $point3d->y, 0, '... got the right (cleared) value for y' );
+is( $point3d->z, 0, '... got the right (cleared) value for z' );
+
+dies_ok {
+ Point3D->new( x => 10, y => 'Foo', z => 3 );
+}
+'... cannot assign a non-Int to y';
+
+dies_ok {
+ Point3D->new( x => 'Foo', y => 10, z => 3 );
+}
+'... cannot assign a non-Int to x';
+
+dies_ok {
+ Point3D->new( x => 0, y => 10, z => 'Bar' );
+}
+'... cannot assign a non-Int to z';
+
+dies_ok {
+ Point3D->new( x => 10, y => 3 );
+}
+'... z is a required attribute for Point3D';
+
+# test some class introspection
+
+can_ok( 'Point', 'meta' );
+isa_ok( Point->meta, 'Moose::Meta::Class' );
+
+can_ok( 'Point3D', 'meta' );
+isa_ok( Point3D->meta, 'Moose::Meta::Class' );
+
+isnt( Point->meta, Point3D->meta,
+ '... they are different metaclasses as well' );
+
+# poke at Point
+
+is_deeply(
+ [ Point->meta->superclasses ],
+ ['Moose::Object'],
+ '... Point got the automagic base class'
+);
+
+my @Point_methods = qw(meta x y clear);
+my @Point_attrs = ( 'x', 'y' );
+
+is_deeply(
+ [ sort @Point_methods ],
+ [ sort Point->meta->get_method_list() ],
+ '... we match the method list for Point'
+);
+
+is_deeply(
+ [ sort @Point_attrs ],
+ [ sort Point->meta->get_attribute_list() ],
+ '... we match the attribute list for Point'
+);
+
+foreach my $method (@Point_methods) {
+ ok( Point->meta->has_method($method),
+ '... Point has the method "' . $method . '"' );
+}
+
+foreach my $attr_name (@Point_attrs) {
+ ok( Point->meta->has_attribute($attr_name),
+ '... Point has the attribute "' . $attr_name . '"' );
+ my $attr = Point->meta->get_attribute($attr_name);
+ ok( $attr->has_type_constraint,
+ '... Attribute ' . $attr_name . ' has a type constraint' );
+ isa_ok( $attr->type_constraint, 'Moose::Meta::TypeConstraint' );
+ is( $attr->type_constraint->name, 'Int',
+ '... Attribute ' . $attr_name . ' has an Int type constraint' );
+}
+
+# poke at Point3D
+
+is_deeply(
+ [ Point3D->meta->superclasses ],
+ ['Point'],
+ '... Point3D gets the parent given to it'
+);
+
+my @Point3D_methods = qw( meta z clear );
+my @Point3D_attrs = ('z');
+
+is_deeply(
+ [ sort @Point3D_methods ],
+ [ sort Point3D->meta->get_method_list() ],
+ '... we match the method list for Point3D'
+);
+
+is_deeply(
+ [ sort @Point3D_attrs ],
+ [ sort Point3D->meta->get_attribute_list() ],
+ '... we match the attribute list for Point3D'
+);
+
+foreach my $method (@Point3D_methods) {
+ ok( Point3D->meta->has_method($method),
+ '... Point3D has the method "' . $method . '"' );
+}
+
+foreach my $attr_name (@Point3D_attrs) {
+ ok( Point3D->meta->has_attribute($attr_name),
+ '... Point3D has the attribute "' . $attr_name . '"' );
+ my $attr = Point3D->meta->get_attribute($attr_name);
+ ok( $attr->has_type_constraint,
+ '... Attribute ' . $attr_name . ' has a type constraint' );
+ isa_ok( $attr->type_constraint, 'Moose::Meta::TypeConstraint' );
+ is( $attr->type_constraint->name, 'Int',
+ '... Attribute ' . $attr_name . ' has an Int type constraint' );
+}
+
+=end testing
+
=cut
);
And as with the first recipe, a more in-depth example can be found in
-the F<t/000_recipes/basics/002_recipe.t> test file.
+the F<t/000_recipes/moose_cookbook_basics_recipe2.t> test file.
=head1 CONCLUSION
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+my $savings_account;
+
+{
+ $savings_account = BankAccount->new( balance => 250 );
+ isa_ok( $savings_account, 'BankAccount' );
+
+ is( $savings_account->balance, 250, '... got the right savings balance' );
+ lives_ok {
+ $savings_account->withdraw(50);
+ }
+ '... withdrew from savings successfully';
+ is( $savings_account->balance, 200,
+ '... got the right savings balance after withdrawl' );
+
+ $savings_account->deposit(150);
+ is( $savings_account->balance, 350,
+ '... got the right savings balance after deposit' );
+}
+
+{
+ my $checking_account = CheckingAccount->new(
+ balance => 100,
+ overdraft_account => $savings_account
+ );
+ isa_ok( $checking_account, 'CheckingAccount' );
+ isa_ok( $checking_account, 'BankAccount' );
+
+ is( $checking_account->overdraft_account, $savings_account,
+ '... got the right overdraft account' );
+
+ is( $checking_account->balance, 100,
+ '... got the right checkings balance' );
+
+ lives_ok {
+ $checking_account->withdraw(50);
+ }
+ '... withdrew from checking successfully';
+ is( $checking_account->balance, 50,
+ '... got the right checkings balance after withdrawl' );
+ is( $savings_account->balance, 350,
+ '... got the right savings balance after checking withdrawl (no overdraft)'
+ );
+
+ lives_ok {
+ $checking_account->withdraw(200);
+ }
+ '... withdrew from checking successfully';
+ is( $checking_account->balance, 0,
+ '... got the right checkings balance after withdrawl' );
+ is( $savings_account->balance, 200,
+ '... got the right savings balance after overdraft withdrawl' );
+}
+
+{
+ my $checking_account = CheckingAccount->new(
+ balance => 100
+
+ # no overdraft account
+ );
+ isa_ok( $checking_account, 'CheckingAccount' );
+ isa_ok( $checking_account, 'BankAccount' );
+
+ is( $checking_account->overdraft_account, undef,
+ '... no overdraft account' );
+
+ is( $checking_account->balance, 100,
+ '... got the right checkings balance' );
+
+ lives_ok {
+ $checking_account->withdraw(50);
+ }
+ '... withdrew from checking successfully';
+ is( $checking_account->balance, 50,
+ '... got the right checkings balance after withdrawl' );
+
+ dies_ok {
+ $checking_account->withdraw(200);
+ }
+ '... withdrawl failed due to attempted overdraft';
+ is( $checking_account->balance, 50,
+ '... got the right checkings balance after withdrawl failure' );
+}
+
+=end testing
+
=cut
As with all the other recipes, B<BinaryTree> can be used just like any
other Perl 5 class. A more detailed example of its usage can be found
-in F<t/000_recipes/003_recipe.t>.
+in F<t/000_recipes/moose_cookbook_basics_recipe3.t>.
=head1 CONCLUSION
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+use Scalar::Util 'isweak';
+
+my $root = BinaryTree->new(node => 'root');
+isa_ok($root, 'BinaryTree');
+
+is($root->node, 'root', '... got the right node value');
+
+ok(!$root->has_left, '... no left node yet');
+ok(!$root->has_right, '... no right node yet');
+
+ok(!$root->has_parent, '... no parent for root node');
+
+# make a left node
+
+my $left = $root->left;
+isa_ok($left, 'BinaryTree');
+
+is($root->left, $left, '... got the same node (and it is $left)');
+ok($root->has_left, '... we have a left node now');
+
+ok($left->has_parent, '... lefts has a parent');
+is($left->parent, $root, '... lefts parent is the root');
+
+ok(isweak($left->{parent}), '... parent is a weakened ref');
+
+ok(!$left->has_left, '... $left no left node yet');
+ok(!$left->has_right, '... $left no right node yet');
+
+is($left->node, undef, '... left has got no node value');
+
+lives_ok {
+ $left->node('left')
+} '... assign to lefts node';
+
+is($left->node, 'left', '... left now has a node value');
+
+# make a right node
+
+ok(!$root->has_right, '... still no right node yet');
+
+is($root->right->node, undef, '... right has got no node value');
+
+ok($root->has_right, '... now we have a right node');
+
+my $right = $root->right;
+isa_ok($right, 'BinaryTree');
+
+lives_ok {
+ $right->node('right')
+} '... assign to rights node';
+
+is($right->node, 'right', '... left now has a node value');
+
+is($root->right, $right, '... got the same node (and it is $right)');
+ok($root->has_right, '... we have a right node now');
+
+ok($right->has_parent, '... rights has a parent');
+is($right->parent, $root, '... rights parent is the root');
+
+ok(isweak($right->{parent}), '... parent is a weakened ref');
+
+# make a left node of the left node
+
+my $left_left = $left->left;
+isa_ok($left_left, 'BinaryTree');
+
+ok($left_left->has_parent, '... left does have a parent');
+
+is($left_left->parent, $left, '... got a parent node (and it is $left)');
+ok($left->has_left, '... we have a left node now');
+is($left->left, $left_left, '... got a left node (and it is $left_left)');
+
+ok(isweak($left_left->{parent}), '... parent is a weakened ref');
+
+# make a right node of the left node
+
+my $left_right = BinaryTree->new;
+isa_ok($left_right, 'BinaryTree');
+
+lives_ok {
+ $left->right($left_right)
+} '... assign to rights node';
+
+ok($left_right->has_parent, '... left does have a parent');
+
+is($left_right->parent, $left, '... got a parent node (and it is $left)');
+ok($left->has_right, '... we have a left node now');
+is($left->right, $left_right, '... got a left node (and it is $left_left)');
+
+ok(isweak($left_right->{parent}), '... parent is a weakened ref');
+
+# and check the error
+
+dies_ok {
+ $left_right->right($left_left)
+} '... cant assign a node which already has a parent';
+
+=end testing
+
=cut
=pod
+=begin testing SETUP
+
+BEGIN {
+ eval 'use Regexp::Common; use Locale::US;';
+ if ($@) {
+ diag 'Regexp::Common & Locale::US required for this test';
+ ok(1);
+ exit 0;
+ }
+}
+
+=end testing
+
=head1 NAME
Moose::Cookbook::Basics::Recipe4 - Subtypes, and modeling a simple B<Company> class hierarchy
sub BUILD {
my ( $self, $params ) = @_;
- if ( @{ $self->employees } ) {
+ if ( @{ $self->employees || [] } ) {
foreach my $employee ( @{ $self->employees } ) {
- $employee->company($self);
+ $employee->employer($self);
}
}
}
my ( $self, $employees ) = @_;
if ($employees) {
foreach my $employee ( @{$employees} ) {
- $employee->company($self);
+ $employee->employer($self);
}
}
};
my ( $self, $params ) = @_;
if ( $self->employees ) {
foreach my $employee ( @{ $self->employees } ) {
- $employee->company($self);
+ $employee->employer($self);
}
}
}
my ( $self, $employees ) = @_;
if ($employees) {
foreach my $employee ( @{$employees} ) {
- $employee->company($self);
+ $employee->employer($self);
}
}
};
parameters that were passed to the method.
A more detailed example of usage can be found in
-F<t/000_recipes/004_recipe.t>.
+F<t/000_recipes/moose_cookbook_basics_recipe4.t>.
=head1 CONCLUSION
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+{
+ package Company;
+
+ sub get_employee_count { scalar @{(shift)->employees} }
+}
+
+use Scalar::Util 'isweak';
+
+my $ii;
+lives_ok {
+ $ii = Company->new(
+ {
+ name => 'Infinity Interactive',
+ address => Address->new(
+ street => '565 Plandome Rd., Suite 307',
+ city => 'Manhasset',
+ state => 'NY',
+ zip_code => '11030'
+ ),
+ employees => [
+ Employee->new(
+ first_name => 'Jeremy',
+ last_name => 'Shao',
+ title => 'President / Senior Consultant',
+ address =>
+ Address->new( city => 'Manhasset', state => 'NY' )
+ ),
+ Employee->new(
+ first_name => 'Tommy',
+ last_name => 'Lee',
+ title => 'Vice President / Senior Developer',
+ address =>
+ Address->new( city => 'New York', state => 'NY' )
+ ),
+ Employee->new(
+ first_name => 'Stevan',
+ middle_initial => 'C',
+ last_name => 'Little',
+ title => 'Senior Developer',
+ address =>
+ Address->new( city => 'Madison', state => 'CT' )
+ ),
+ ]
+ }
+ );
+}
+'... created the entire company successfully';
+isa_ok( $ii, 'Company' );
+
+is( $ii->name, 'Infinity Interactive',
+ '... got the right name for the company' );
+
+isa_ok( $ii->address, 'Address' );
+is( $ii->address->street, '565 Plandome Rd., Suite 307',
+ '... got the right street address' );
+is( $ii->address->city, 'Manhasset', '... got the right city' );
+is( $ii->address->state, 'NY', '... got the right state' );
+is( $ii->address->zip_code, 11030, '... got the zip code' );
+
+is( $ii->get_employee_count, 3, '... got the right employee count' );
+
+# employee #1
+
+isa_ok( $ii->employees->[0], 'Employee' );
+isa_ok( $ii->employees->[0], 'Person' );
+
+is( $ii->employees->[0]->first_name, 'Jeremy',
+ '... got the right first name' );
+is( $ii->employees->[0]->last_name, 'Shao', '... got the right last name' );
+ok( !$ii->employees->[0]->has_middle_initial, '... no middle initial' );
+is( $ii->employees->[0]->middle_initial, undef,
+ '... got the right middle initial value' );
+is( $ii->employees->[0]->full_name,
+ 'Jeremy Shao, President / Senior Consultant',
+ '... got the right full name' );
+is( $ii->employees->[0]->title, 'President / Senior Consultant',
+ '... got the right title' );
+is( $ii->employees->[0]->employer, $ii, '... got the right company' );
+ok( isweak( $ii->employees->[0]->{employer} ),
+ '... the company is a weak-ref' );
+
+isa_ok( $ii->employees->[0]->address, 'Address' );
+is( $ii->employees->[0]->address->city, 'Manhasset',
+ '... got the right city' );
+is( $ii->employees->[0]->address->state, 'NY', '... got the right state' );
+
+# employee #2
+
+isa_ok( $ii->employees->[1], 'Employee' );
+isa_ok( $ii->employees->[1], 'Person' );
+
+is( $ii->employees->[1]->first_name, 'Tommy',
+ '... got the right first name' );
+is( $ii->employees->[1]->last_name, 'Lee', '... got the right last name' );
+ok( !$ii->employees->[1]->has_middle_initial, '... no middle initial' );
+is( $ii->employees->[1]->middle_initial, undef,
+ '... got the right middle initial value' );
+is( $ii->employees->[1]->full_name,
+ 'Tommy Lee, Vice President / Senior Developer',
+ '... got the right full name' );
+is( $ii->employees->[1]->title, 'Vice President / Senior Developer',
+ '... got the right title' );
+is( $ii->employees->[1]->employer, $ii, '... got the right company' );
+ok( isweak( $ii->employees->[1]->{employer} ),
+ '... the company is a weak-ref' );
+
+isa_ok( $ii->employees->[1]->address, 'Address' );
+is( $ii->employees->[1]->address->city, 'New York',
+ '... got the right city' );
+is( $ii->employees->[1]->address->state, 'NY', '... got the right state' );
+
+# employee #3
+
+isa_ok( $ii->employees->[2], 'Employee' );
+isa_ok( $ii->employees->[2], 'Person' );
+
+is( $ii->employees->[2]->first_name, 'Stevan',
+ '... got the right first name' );
+is( $ii->employees->[2]->last_name, 'Little', '... got the right last name' );
+ok( $ii->employees->[2]->has_middle_initial, '... got middle initial' );
+is( $ii->employees->[2]->middle_initial, 'C',
+ '... got the right middle initial value' );
+is( $ii->employees->[2]->full_name, 'Stevan C. Little, Senior Developer',
+ '... got the right full name' );
+is( $ii->employees->[2]->title, 'Senior Developer',
+ '... got the right title' );
+is( $ii->employees->[2]->employer, $ii, '... got the right company' );
+ok( isweak( $ii->employees->[2]->{employer} ),
+ '... the company is a weak-ref' );
+
+isa_ok( $ii->employees->[2]->address, 'Address' );
+is( $ii->employees->[2]->address->city, 'Madison', '... got the right city' );
+is( $ii->employees->[2]->address->state, 'CT', '... got the right state' );
+
+# create new company
+
+my $new_company
+ = Company->new( name => 'Infinity Interactive International' );
+isa_ok( $new_company, 'Company' );
+
+my $ii_employees = $ii->employees;
+foreach my $employee (@$ii_employees) {
+ is( $employee->employer, $ii, '... has the ii company' );
+}
+
+$new_company->employees($ii_employees);
+
+foreach my $employee ( @{ $new_company->employees } ) {
+ is( $employee->employer, $new_company,
+ '... has the different company now' );
+}
+
+## check some error conditions for the subtypes
+
+dies_ok {
+ Address->new( street => {} ),;
+}
+'... we die correctly with bad args';
+
+dies_ok {
+ Address->new( city => {} ),;
+}
+'... we die correctly with bad args';
+
+dies_ok {
+ Address->new( state => 'British Columbia' ),;
+}
+'... we die correctly with bad args';
+
+lives_ok {
+ Address->new( state => 'Connecticut' ),;
+}
+'... we live correctly with good args';
+
+dies_ok {
+ Address->new( zip_code => 'AF5J6$' ),;
+}
+'... we die correctly with bad args';
+
+lives_ok {
+ Address->new( zip_code => '06443' ),;
+}
+'... we live correctly with good args';
+
+dies_ok {
+ Company->new(),;
+}
+'... we die correctly without good args';
+
+lives_ok {
+ Company->new( name => 'Foo' ),;
+}
+'... we live correctly without good args';
+
+dies_ok {
+ Company->new( name => 'Foo', employees => [ Person->new ] ),;
+}
+'... we die correctly with good args';
+
+lives_ok {
+ Company->new( name => 'Foo', employees => [] ),;
+}
+'... we live correctly with good args';
+
+=end testing
+
=cut
=pod
+=begin testing SETUP
+
+BEGIN {
+ eval 'use HTTP::Headers; use Params::Coerce; use URI;';
+ if ($@) {
+ diag 'HTTP::Headers, Params::Coerce & URI required for this test';
+ ok(1);
+ exit 0;
+ }
+}
+
+=end testing
+
=head1 NAME
Moose::Cookbook::Basics::Recipe5 - More subtypes, coercion in a B<Request> class
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+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';
+}
+
+=end testing
+
=cut
}
# <page><header/><report type="tps"/><footer/></page>
- print TPSReport->new->create;
+ my $report_xml = TPSReport->new->create;
=head1 DESCRIPTION
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+my $tps_report = TPSReport->new;
+isa_ok( $tps_report, 'TPSReport' );
+
+is(
+ $tps_report->create,
+ q{<page><header/><report type="tps"/><footer/></page>},
+ '... got the right TPS report'
+);
+
+=end testing
+
=cut
=pod
+=begin testing SETUP
+
+BEGIN {
+ eval 'use Test::Warn 0.11;';
+ if ($@) {
+ diag 'Test::Warn 0.11+ is required for this test';
+ ok(1);
+ exit 0;
+ }
+}
+
+=end testing
+
=head1 NAME
Moose::Cookbook::Extending::Recipe3 - Providing an alternate base object class
sub init_meta {
shift;
- Moose->init_meta( @_, base_class => 'MyApp::Object' );
+ Moose->init_meta( @_, base_class => 'MyApp::Base' );
}
=head1 DESCRIPTION
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+{
+ package Foo;
+
+ MyApp::UseMyBase->import;
+
+ has( 'size' => ( is => 'rw' ) );
+}
+
+ok( Foo->isa('MyApp::Base'), 'Foo isa MyApp::Base' );
+
+ok( Foo->can('size'), 'Foo has a size method' );
+
+my $foo;
+warning_is(
+ sub { $foo = Foo->new( size => 2 ) },
+ 'Making a new Foo',
+ 'got expected warning when calling Foo->new'
+);
+
+is( $foo->size(), 2, '$foo->size is 2' );
+
+=end testing
+
=cut
$caller->meta->table(shift);
}
+ package MyApp::Meta::Class;
+ use Moose;
+
+ extends 'Moose::Meta::Class';
+
+ has 'table' => ( is => 'rw' );
+
=head1 DESCRIPTION
This recipe expands on the use of L<Moose::Exporter> we saw in
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+
+{
+ package MyApp::User;
+
+ MyApp::Mooseish->import;
+
+ has_table( 'User' );
+
+ has( 'username' => ( is => 'ro' ) );
+ has( 'password' => ( is => 'ro' ) );
+
+ sub login { }
+}
+
+isa_ok( MyApp::User->meta, 'MyApp::Meta::Class' );
+is( MyApp::User->meta->table, 'User',
+ 'MyApp::User->meta->table returns User' );
+ok( MyApp::User->can('username'),
+ 'MyApp::User has username method' );
+
+=end testing
+
=pod
package MyApp::Website;
use Moose;
- use MyApp::Meta::Attribute::Labeled;
has url => (
metaclass => 'Labeled',
sub dump {
my $self = shift;
- # iterate over all the attributes in $self
+ my $dump = '';
+
my %attributes = %{ $self->meta->get_attribute_map };
- while ( my ( $name, $attribute ) = each %attributes ) {
+ for my $name ( sort keys %attributes ) {
+ my $attribute = $attributes{$name};
- # print the label if available
if ( $attribute->isa('MyApp::Meta::Attribute::Labeled')
&& $attribute->has_label ) {
- print $attribute->label;
+ $dump .= $attribute->label;
}
-
- # otherwise print the name
else {
- print $name;
+ $dump .= $name;
}
- # print the attribute's value
my $reader = $attribute->get_read_method;
- print ": " . $self->$reader . "\n";
+ $dump .= ": " . $self->$reader . "\n";
}
+
+ return $dump;
}
package main;
+
my $app = MyApp::Website->new( url => "http://google.com", name => "Google" );
- $app->dump;
=head1 SUMMARY
sub dump {
my $self = shift;
- # iterate over all the attributes in $self
+ my $dump = '';
+
my %attributes = %{ $self->meta->get_attribute_map };
- while ( my ( $name, $attribute ) = each %attributes ) {
+ for my $name ( sort keys %attributes ) {
+ my $attribute = $attributes{$name};
- # print the label if available
if ( $attribute->isa('MyApp::Meta::Attribute::Labeled')
&& $attribute->has_label ) {
- print $attribute->label;
+ $dump .= $attribute->label;
}
This is a bit of defensive code. We cannot depend on every
We also check that the attribute has a label using the predicate we
defined. We could instead make the label C<required>. If we have a
-label, we print it, otherwise we print the attribute name:
+label, we use it, otherwise we use the attribute name:
- # otherwise print the name
else {
- print $name;
+ $dump .= $name;
}
- # print the attribute's value
my $reader = $attribute->get_read_method;
- print ": " . $self->$reader . "\n";
+ $dump .= ": " . $self->$reader . "\n";
}
+
+ return $dump;
}
The C<get_read_method> is part of the L<Moose::Meta::Attribute>
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+my $app = MyApp::Website->new( url => "http://google.com", name => "Google" );
+is(
+ $app->dump, q{name: Google
+The site's URL: http://google.com
+}, '... got the expected dump value'
+);
+
+=end testing
+
=cut
package MyApp::Website;
use Moose;
- use MyApp::Meta::Attribute::Trait::Labeled;
has url => (
traits => [qw/Labeled/],
sub dump {
my $self = shift;
- # iterate over all the attributes in $self
+ my $dump = '';
+
my %attributes = %{ $self->meta->get_attribute_map };
- while ( my ( $name, $attribute ) = each %attributes ) {
+ for my $name ( sort keys %attributes ) {
+ my $attribute = $attributes{$name};
- # print the label if available
if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
&& $attribute->has_label ) {
- print $attribute->label;
+ $dump .= $attribute->label;
}
-
- # otherwise print the name
else {
- print $name;
+ $dump .= $name;
}
- # print the attribute's value
my $reader = $attribute->get_read_method;
- print ": " . $self->$reader . "\n";
+ $dump .= ": " . $self->$reader . "\n";
}
+
+ return $dump;
}
package main;
+
my $app = MyApp::Website->new( url => "http://google.com", name => "Google" );
- $app->dump;
=head1 BUT FIRST
attribute. Passing a C<label> parameter works just as it did with the
metaclass example.
- # print the label if available
- if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
- && $attribute->has_label ) {
- print $attribute->label;
- }
+ if ( $attribute->does('MyApp::Meta::Attribute::Trait::Labeled')
+ && $attribute->has_label ) {
+ $dump .= $attribute->label;
+ }
In the metaclass example, we used C<< $attribute->isa >>. With a role,
we instead ask if the meta-attribute object C<does> the required
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
-=cut
+=begin testing
+my $app2
+ = MyApp::Website->new( url => "http://google.com", name => "Google" );
+is(
+ $app2->dump, q{name: Google
+The site's URL: http://google.com
+}, '... got the expected dump value'
+);
+
+=end testing
+
+=cut
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+ok( US::Currency->does('Comparable'), '... US::Currency does Comparable' );
+ok( US::Currency->does('Eq'), '... US::Currency does Eq' );
+ok( US::Currency->does('Printable'), '... US::Currency does Printable' );
+
+my $hundred = US::Currency->new( amount => 100.00 );
+isa_ok( $hundred, 'US::Currency' );
+
+ok( $hundred->DOES("US::Currency"), "UNIVERSAL::DOES for class" );
+ok( $hundred->DOES("Comparable"), "UNIVERSAL::DOES for role" );
+
+can_ok( $hundred, 'amount' );
+is( $hundred->amount, 100, '... got the right amount' );
+
+can_ok( $hundred, 'to_string' );
+is( $hundred->to_string, '$100.00 USD',
+ '... got the right stringified value' );
+
+ok( $hundred->does('Comparable'), '... US::Currency does Comparable' );
+ok( $hundred->does('Eq'), '... US::Currency does Eq' );
+ok( $hundred->does('Printable'), '... US::Currency does Printable' );
+
+my $fifty = US::Currency->new( amount => 50.00 );
+isa_ok( $fifty, 'US::Currency' );
+
+can_ok( $fifty, 'amount' );
+is( $fifty->amount, 50, '... got the right amount' );
+
+can_ok( $fifty, 'to_string' );
+is( $fifty->to_string, '$50.00 USD', '... got the right stringified value' );
+
+ok( $hundred->greater_than($fifty), '... 100 gt 50' );
+ok( $hundred->greater_than_or_equal_to($fifty), '... 100 ge 50' );
+ok( !$hundred->less_than($fifty), '... !100 lt 50' );
+ok( !$hundred->less_than_or_equal_to($fifty), '... !100 le 50' );
+ok( !$hundred->equal_to($fifty), '... !100 eq 50' );
+ok( $hundred->not_equal_to($fifty), '... 100 ne 50' );
+
+ok( !$fifty->greater_than($hundred), '... !50 gt 100' );
+ok( !$fifty->greater_than_or_equal_to($hundred), '... !50 ge 100' );
+ok( $fifty->less_than($hundred), '... 50 lt 100' );
+ok( $fifty->less_than_or_equal_to($hundred), '... 50 le 100' );
+ok( !$fifty->equal_to($hundred), '... !50 eq 100' );
+ok( $fifty->not_equal_to($hundred), '... 50 ne 100' );
+
+ok( !$fifty->greater_than($fifty), '... !50 gt 50' );
+ok( $fifty->greater_than_or_equal_to($fifty), '... !50 ge 50' );
+ok( !$fifty->less_than($fifty), '... 50 lt 50' );
+ok( $fifty->less_than_or_equal_to($fifty), '... 50 le 50' );
+ok( $fifty->equal_to($fifty), '... 50 eq 50' );
+ok( !$fifty->not_equal_to($fifty), '... !50 ne 50' );
+
+## ... check some meta-stuff
+
+# Eq
+
+my $eq_meta = Eq->meta;
+isa_ok( $eq_meta, 'Moose::Meta::Role' );
+
+ok( $eq_meta->has_method('not_equal_to'), '... Eq has_method not_equal_to' );
+ok( $eq_meta->requires_method('equal_to'),
+ '... Eq requires_method not_equal_to' );
+
+# Comparable
+
+my $comparable_meta = Comparable->meta;
+isa_ok( $comparable_meta, 'Moose::Meta::Role' );
+
+ok( $comparable_meta->does_role('Eq'), '... Comparable does Eq' );
+
+foreach my $method_name (
+ qw(
+ equal_to not_equal_to
+ greater_than greater_than_or_equal_to
+ less_than less_than_or_equal_to
+ )
+ ) {
+ ok( $comparable_meta->has_method($method_name),
+ '... Comparable has_method ' . $method_name );
+}
+
+ok( $comparable_meta->requires_method('compare'),
+ '... Comparable requires_method compare' );
+
+# Printable
+
+my $printable_meta = Printable->meta;
+isa_ok( $printable_meta, 'Moose::Meta::Role' );
+
+ok( $printable_meta->requires_method('to_string'),
+ '... Printable requires_method to_string' );
+
+# US::Currency
+
+my $currency_meta = US::Currency->meta;
+isa_ok( $currency_meta, 'Moose::Meta::Class' );
+
+ok( $currency_meta->does_role('Comparable'),
+ '... US::Currency does Comparable' );
+ok( $currency_meta->does_role('Eq'), '... US::Currency does Eq' );
+ok( $currency_meta->does_role('Printable'),
+ '... US::Currency does Printable' );
+
+foreach my $method_name (
+ qw(
+ amount
+ equal_to not_equal_to
+ compare
+ greater_than greater_than_or_equal_to
+ less_than less_than_or_equal_to
+ to_string
+ )
+ ) {
+ ok( $currency_meta->has_method($method_name),
+ '... US::Currency has_method ' . $method_name );
+}
+
+=end testing
+
=cut
requires 'save_state', 'load_state';
- sub stop { ... }
+ sub stop { 1 }
- sub start { ... }
+ sub start { 1 }
package Restartable::ButUnreliable;
use Moose::Role;
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+=begin testing
+
+{
+ my $unreliable = Moose::Meta::Class->create_anon_class(
+ superclasses => [],
+ roles => [qw/Restartable::ButUnreliable/],
+ methods => {
+ explode => sub { }, # nop.
+ 'save_state' => sub { },
+ 'load_state' => sub { },
+ },
+ )->new_object();
+ ok( $unreliable, 'made anon class with Restartable::ButUnreliable role' );
+ can_ok( $unreliable, qw/start stop/ );
+}
+
+{
+ my $cnt = 0;
+ my $broken = Moose::Meta::Class->create_anon_class(
+ superclasses => [],
+ roles => [qw/Restartable::ButBroken/],
+ methods => {
+ explode => sub { $cnt++ },
+ 'save_state' => sub { },
+ 'load_state' => sub { },
+ },
+ )->new_object();
+
+ ok( $broken, 'made anon class with Restartable::ButBroken role' );
+
+ $broken->start();
+
+ is( $cnt, 1, '... start called explode' );
+
+ $broken->stop();
+
+ is( $cnt, 2, '... stop also called explode' );
+}
+
+=end testing
+
=cut
+package Moose::Cookbook::Roles::Recipe3;
=pod
+=begin testing SETUP
+
+{
+ # Not in the recipe, but needed for writing tests.
+ package Employee;
+
+ use Moose;
+
+ has 'name' => (
+ is => 'ro',
+ isa => 'Str',
+ required => 1,
+ );
+
+ has 'work' => (
+ is => 'rw',
+ isa => 'Str',
+ predicate => 'has_work',
+ );
+}
+
+=end testing
+
=head1 NAME
Moose::Cookbook::Roles::Recipe3 - Applying a role to an object instance
die 'All my employees have work to do!' unless $employee;
- $employee->assign_work($work);
+ $employee->work($work);
}
package main;
This library is free software; you can redistribute it and/or modify
it under the same terms as Perl itself.
+
+=begin testing
+
+{
+ my $lisa = Employee->new( name => 'Lisa' );
+ MyApp::Role::Job::Manager->meta->apply($lisa);
+
+ my $homer = Employee->new( name => 'Homer' );
+ my $bart = Employee->new( name => 'Bart' );
+ my $marge = Employee->new( name => 'Marge' );
+
+ $lisa->employees( [ $homer, $bart, $marge ] );
+ $lisa->assign_work('mow the lawn');
+
+ ok( $lisa->does('MyApp::Role::Job::Manager'),
+ 'lisa now does the manager role' );
+
+ is( $homer->work, 'mow the lawn',
+ 'homer was assigned a task by lisa' );
+}
+
+=end testing
+
=cut
projects / gitmo/Moose.git / commitdiff