From: Dave Rolsky Date: Wed, 18 Feb 2009 20:19:08 +0000 (+0000) Subject: Add tool for extracting inline tests. X-Git-Tag: 0.71~8 X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?a=commitdiff_plain;h=c79239a22fc3b30cac35dec0d704c7da52872aa5;p=gitmo%2FMoose.git Add tool for extracting inline tests. Moved all the recipe tests (except basics 10) to inline tests, which found a number of bugs along the way. --- diff --git a/extract-inline-tests b/extract-inline-tests new file mode 100755 index 0000000..a710ec1 --- /dev/null +++ b/extract-inline-tests @@ -0,0 +1,103 @@ +#!/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; diff --git a/lib/Moose/Cookbook/Basics/Recipe1.pod b/lib/Moose/Cookbook/Basics/Recipe1.pod index 9c1bf6e..4e5fb91 100644 --- a/lib/Moose/Cookbook/Basics/Recipe1.pod +++ b/lib/Moose/Cookbook/Basics/Recipe1.pod @@ -31,7 +31,7 @@ Moose::Cookbook::Basics::Recipe1 - The (always classic) B example. $self->z(0); }; - .... + package main; # hash or hashrefs are ok for the constructor my $point1 = Point->new(x => 5, y => 7); @@ -162,8 +162,8 @@ required, and calling C without them will throw an error. 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 test -file. +done, you can refer to the +F test file. =head2 Moose Objects are Just Hashrefs @@ -238,4 +238,176 @@ L 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 diff --git a/lib/Moose/Cookbook/Basics/Recipe2.pod b/lib/Moose/Cookbook/Basics/Recipe2.pod index f3ac9ed..832dea7 100644 --- a/lib/Moose/Cookbook/Basics/Recipe2.pod +++ b/lib/Moose/Cookbook/Basics/Recipe2.pod @@ -157,7 +157,7 @@ method, which accepts named parameters. ); And as with the first recipe, a more in-depth example can be found in -the F test file. +the F test file. =head1 CONCLUSION @@ -227,4 +227,91 @@ L 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 diff --git a/lib/Moose/Cookbook/Basics/Recipe3.pod b/lib/Moose/Cookbook/Basics/Recipe3.pod index a795ff1..9ddb624 100644 --- a/lib/Moose/Cookbook/Basics/Recipe3.pod +++ b/lib/Moose/Cookbook/Basics/Recipe3.pod @@ -183,7 +183,7 @@ ensure that is has the correct value for its C attribute. As with all the other recipes, B can be used just like any other Perl 5 class. A more detailed example of its usage can be found -in F. +in F. =head1 CONCLUSION @@ -230,4 +230,105 @@ L 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 diff --git a/lib/Moose/Cookbook/Basics/Recipe4.pod b/lib/Moose/Cookbook/Basics/Recipe4.pod index f6748f7..6e150f5 100644 --- a/lib/Moose/Cookbook/Basics/Recipe4.pod +++ b/lib/Moose/Cookbook/Basics/Recipe4.pod @@ -1,6 +1,19 @@ =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 class hierarchy @@ -43,9 +56,9 @@ Moose::Cookbook::Basics::Recipe4 - Subtypes, and modeling a simple B cl sub BUILD { my ( $self, $params ) = @_; - if ( @{ $self->employees } ) { + if ( @{ $self->employees || [] } ) { foreach my $employee ( @{ $self->employees } ) { - $employee->company($self); + $employee->employer($self); } } } @@ -54,7 +67,7 @@ Moose::Cookbook::Basics::Recipe4 - Subtypes, and modeling a simple B cl my ( $self, $employees ) = @_; if ($employees) { foreach my $employee ( @{$employees} ) { - $employee->company($self); + $employee->employer($self); } } }; @@ -202,7 +215,7 @@ C attribute: my ( $self, $params ) = @_; if ( $self->employees ) { foreach my $employee ( @{ $self->employees } ) { - $employee->company($self); + $employee->employer($self); } } } @@ -222,7 +235,7 @@ To do this we can use an C modifier: my ( $self, $employees ) = @_; if ($employees) { foreach my $employee ( @{$employees} ) { - $employee->company($self); + $employee->employer($self); } } }; @@ -249,7 +262,7 @@ arguments to C. Instead, Moose simply passes the same parameters that were passed to the method. A more detailed example of usage can be found in -F. +F. =head1 CONCLUSION @@ -303,4 +316,212 @@ L 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 diff --git a/lib/Moose/Cookbook/Basics/Recipe5.pod b/lib/Moose/Cookbook/Basics/Recipe5.pod index 9b74d3e..2dee852 100644 --- a/lib/Moose/Cookbook/Basics/Recipe5.pod +++ b/lib/Moose/Cookbook/Basics/Recipe5.pod @@ -1,6 +1,19 @@ =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 class @@ -208,4 +221,66 @@ L 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 diff --git a/lib/Moose/Cookbook/Basics/Recipe6.pod b/lib/Moose/Cookbook/Basics/Recipe6.pod index a46e4c0..dcbc07f 100644 --- a/lib/Moose/Cookbook/Basics/Recipe6.pod +++ b/lib/Moose/Cookbook/Basics/Recipe6.pod @@ -58,7 +58,7 @@ Moose::Cookbook::Basics::Recipe6 - The augment/inner example } #