Add tool for extracting inline tests.
Dave Rolsky [Wed, 18 Feb 2009 20:19:08 +0000 (20:19 +0000)]
Moved all the recipe tests (except basics 10) to inline tests, which
found a number of bugs along the way.

14 files changed:
extract-inline-tests [new file with mode: 0755]
lib/Moose/Cookbook/Basics/Recipe1.pod
lib/Moose/Cookbook/Basics/Recipe2.pod
lib/Moose/Cookbook/Basics/Recipe3.pod
lib/Moose/Cookbook/Basics/Recipe4.pod
lib/Moose/Cookbook/Basics/Recipe5.pod
lib/Moose/Cookbook/Basics/Recipe6.pod
lib/Moose/Cookbook/Extending/Recipe3.pod
lib/Moose/Cookbook/Extending/Recipe4.pod
lib/Moose/Cookbook/Meta/Recipe2.pod
lib/Moose/Cookbook/Meta/Recipe3.pod
lib/Moose/Cookbook/Roles/Recipe1.pod
lib/Moose/Cookbook/Roles/Recipe2.pod
lib/Moose/Cookbook/Roles/Recipe3.pod

diff --git a/extract-inline-tests b/extract-inline-tests
new file mode 100755 (executable)
index 0000000..a710ec1
--- /dev/null
@@ -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;
index 9c1bf6e..4e5fb91 100644 (file)
@@ -31,7 +31,7 @@ Moose::Cookbook::Basics::Recipe1 - The (always classic) B<Point> 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<new> 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<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
 
@@ -238,4 +238,176 @@ 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.
 
+=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
index f3ac9ed..832dea7 100644 (file)
@@ -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<t/000_recipes/basics/002_recipe.t> test file.
+the F<t/000_recipes/moose_cookbook_basics_recipe2.t> test file.
 
 =head1 CONCLUSION
 
@@ -227,4 +227,91 @@ 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.
 
+=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
index a795ff1..9ddb624 100644 (file)
@@ -183,7 +183,7 @@ ensure that is has the correct value for its C<parent> attribute.
 
 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
 
@@ -230,4 +230,105 @@ 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.
 
+=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
index f6748f7..6e150f5 100644 (file)
@@ -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<Company> class hierarchy
@@ -43,9 +56,9 @@ Moose::Cookbook::Basics::Recipe4 - Subtypes, and modeling a simple B<Company> 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<Company> cl
       my ( $self, $employees ) = @_;
       if ($employees) {
           foreach my $employee ( @{$employees} ) {
-              $employee->company($self);
+              $employee->employer($self);
           }
       }
   };
@@ -202,7 +215,7 @@ C<employer> 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<after> modifier:
       my ( $self, $employees ) = @_;
       if ($employees) {
           foreach my $employee ( @{$employees} ) {
-              $employee->company($self);
+              $employee->employer($self);
           }
       }
   };
@@ -249,7 +262,7 @@ arguments to C<super>. Instead, Moose simply passes the same
 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
 
@@ -303,4 +316,212 @@ 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.
 
+=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
index 9b74d3e..2dee852 100644 (file)
@@ -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<Request> class
@@ -208,4 +221,66 @@ 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.
 
+=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
index a46e4c0..dcbc07f 100644 (file)
@@ -58,7 +58,7 @@ Moose::Cookbook::Basics::Recipe6 - The augment/inner example
   }
 
   # <page><header/><report type="tps"/><footer/></page>
-  print TPSReport->new->create;
+  my $report_xml = TPSReport->new->create;
 
 =head1 DESCRIPTION
 
@@ -133,4 +133,17 @@ 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.
 
+=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
index 7db8b12..86aeec6 100644 (file)
@@ -1,6 +1,19 @@
 
 =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
@@ -24,7 +37,7 @@ 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
@@ -87,4 +100,29 @@ 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.
 
+=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
index 6ca5cd1..30421f1 100644 (file)
@@ -30,6 +30,13 @@ Moose::Cookbook::Extending::Recipe4 - Acting like Moose.pm and providing sugar M
       $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
@@ -87,4 +94,28 @@ 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.
 
+=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
index f9e3db5..4c38c19 100644 (file)
@@ -22,7 +22,6 @@ Moose::Cookbook::Meta::Recipe2 - A meta-attribute, attributes with labels
 
   package MyApp::Website;
   use Moose;
-  use MyApp::Meta::Attribute::Labeled;
 
   has url => (
       metaclass => 'Labeled',
@@ -39,30 +38,30 @@ Moose::Cookbook::Meta::Recipe2 - A meta-attribute, attributes with labels
   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
 
@@ -201,14 +200,15 @@ attribute's label if it has one.
   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
@@ -218,17 +218,17 @@ superclass could add an attribute without a label.
 
 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>
@@ -277,5 +277,16 @@ 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.
 
+=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
 
index 673d7fb..fd2cc16 100644 (file)
@@ -21,7 +21,6 @@ Moose::Cookbook::Meta::Recipe3 - Labels implemented via attribute traits
 
   package MyApp::Website;
   use Moose;
-  use MyApp::Meta::Attribute::Trait::Labeled;
 
   has url => (
       traits => [qw/Labeled/],
@@ -38,30 +37,30 @@ Moose::Cookbook::Meta::Recipe3 - Labels implemented via attribute traits
   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
 
@@ -144,11 +143,10 @@ anonymous attribute metaclass from these traits and use it for this
 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
@@ -200,6 +198,17 @@ 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
+=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
index f36ce03..7478c19 100644 (file)
@@ -208,4 +208,124 @@ 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.
 
+=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
index e7ff270..7a76c0f 100644 (file)
@@ -18,9 +18,9 @@ Moose::Cookbook::Roles::Recipe2 - Advanced Role Composition - method exclusion a
 
   requires 'save_state', 'load_state';
 
-  sub stop { ... }
+  sub stop { 1 }
 
-  sub start { ... }
+  sub start { 1 }
 
   package Restartable::ButUnreliable;
   use Moose::Role;
@@ -131,4 +131,45 @@ 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.
 
+=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
index 6e38fd2..c6faf8e 100644 (file)
@@ -1,6 +1,30 @@
+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
@@ -26,7 +50,7 @@ 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;
@@ -93,4 +117,27 @@ 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.
 
+
+=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