From: gfx <gfuji@cpan.org>
Date: Wed, 23 Sep 2009 06:01:02 +0000 (+0900)
Subject: Add tests for recipes, just copied from Moose
X-Git-Tag: 0.33~2
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=de3f9ba5c62f6e2b1cf64d057ffef60224b4204a

Add tests for recipes, just copied from Moose
---

diff --git a/t/000-recipes/moose_cookbook_basics_recipe2.t b/t/000-recipes/moose_cookbook_basics_recipe2.t
new file mode 100644
index 0000000..d7cb28f
--- /dev/null
+++ b/t/000-recipes/moose_cookbook_basics_recipe2.t
@@ -0,0 +1,148 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+BEGIN{
+    if(eval{ require Class::Method::Modifiers::Fast } || eval{ require Class::Method::Modifiers }){
+        plan 'no_plan';
+    }
+    else{
+        plan skip_all => 'This test requires Class::Method::Modifiers(::Fast)?';
+    }
+}
+
+use Test::Exception;
+$| = 1;
+
+
+
+# =begin testing SETUP
+{
+
+  package BankAccount;
+  use Mouse;
+
+  has 'balance' => ( isa => 'Int', is => 'rw', default => 0 );
+
+  sub deposit {
+      my ( $self, $amount ) = @_;
+      $self->balance( $self->balance + $amount );
+  }
+
+  sub withdraw {
+      my ( $self, $amount ) = @_;
+      my $current_balance = $self->balance();
+      ( $current_balance >= $amount )
+          || confess "Account overdrawn";
+      $self->balance( $current_balance - $amount );
+  }
+
+  package CheckingAccount;
+  use Mouse;
+
+  extends 'BankAccount';
+
+  has 'overdraft_account' => ( isa => 'BankAccount', is => 'rw' );
+
+  before 'withdraw' => sub {
+      my ( $self, $amount ) = @_;
+      my $overdraft_amount = $amount - $self->balance();
+      if ( $self->overdraft_account && $overdraft_amount > 0 ) {
+          $self->overdraft_account->withdraw($overdraft_amount);
+          $self->deposit($overdraft_amount);
+      }
+  };
+}
+
+
+
+# =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' );
+}
+}
+
+
+
+
+1;
diff --git a/t/000-recipes/moose_cookbook_basics_recipe3.t b/t/000-recipes/moose_cookbook_basics_recipe3.t
new file mode 100644
index 0000000..db3f5cb
--- /dev/null
+++ b/t/000-recipes/moose_cookbook_basics_recipe3.t
@@ -0,0 +1,158 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 'no_plan';
+use Test::Exception;
+$| = 1;
+
+
+
+# =begin testing SETUP
+{
+
+  package BinaryTree;
+  use Mouse;
+
+  has 'node' => ( is => 'rw', isa => 'Any' );
+
+  has 'parent' => (
+      is        => 'rw',
+      isa       => 'BinaryTree',
+      predicate => 'has_parent',
+      weak_ref  => 1,
+  );
+
+  has 'left' => (
+      is        => 'rw',
+      isa       => 'BinaryTree',
+      predicate => 'has_left',
+      lazy      => 1,
+      default   => sub { BinaryTree->new( parent => $_[0] ) },
+      trigger   => \&_set_parent_for_child
+  );
+
+  has 'right' => (
+      is        => 'rw',
+      isa       => 'BinaryTree',
+      predicate => 'has_right',
+      lazy      => 1,
+      default   => sub { BinaryTree->new( parent => $_[0] ) },
+      trigger   => \&_set_parent_for_child
+  );
+
+  sub _set_parent_for_child {
+      my ( $self, $child ) = @_;
+
+      confess "You cannot insert a tree which already has a parent"
+          if $child->has_parent;
+
+      $child->parent($self);
+  }
+}
+
+
+
+# =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';
+}
+
+
+
+
+1;
diff --git a/t/000-recipes/moose_cookbook_basics_recipe4.t b/t/000-recipes/moose_cookbook_basics_recipe4.t
new file mode 100644
index 0000000..c7f0089
--- /dev/null
+++ b/t/000-recipes/moose_cookbook_basics_recipe4.t
@@ -0,0 +1,337 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More;
+BEGIN{
+    if(eval{ require Class::Method::Modifiers::Fast } || eval{ require Class::Method::Modifiers }){
+        eval 'use Regexp::Common; use Locale::US;';
+        if ($@) {
+            plan skip_all => 'Regexp::Common & Locale::US required for this test';
+        }
+        else{
+            plan 'no_plan';
+        }
+    }
+    else{
+        plan skip_all => 'This test requires Class::Method::Modifiers(::Fast)?';
+    }
+}
+
+use Test::Exception;
+$| = 1;
+
+
+
+# =begin testing SETUP
+BEGIN {
+    eval 'use Regexp::Common; use Locale::US;';
+    if ($@) {
+        plan skip_all => 'Regexp::Common & Locale::US required for this test';
+    }
+}
+
+
+
+# =begin testing SETUP
+{
+
+  package Address;
+  use Mouse;
+  use Mouse::Util::TypeConstraints;
+
+  use Locale::US;
+  use Regexp::Common 'zip';
+
+  my $STATES = Locale::US->new;
+  subtype 'USState'
+      => as Str
+      => where {
+             (    exists $STATES->{code2state}{ uc($_) }
+               || exists $STATES->{state2code}{ uc($_) } );
+         };
+
+  subtype 'USZipCode'
+      => as Value
+      => where {
+             /^$RE{zip}{US}{-extended => 'allow'}$/;
+         };
+
+  has 'street'   => ( is => 'rw', isa => 'Str' );
+  has 'city'     => ( is => 'rw', isa => 'Str' );
+  has 'state'    => ( is => 'rw', isa => 'USState' );
+  has 'zip_code' => ( is => 'rw', isa => 'USZipCode' );
+
+  package Company;
+  use Mouse;
+  use Mouse::Util::TypeConstraints;
+
+  has 'name' => ( is => 'rw', isa => 'Str', required => 1 );
+  has 'address'   => ( is => 'rw', isa => 'Address' );
+  has 'employees' => ( is => 'rw', isa => 'ArrayRef[Employee]' );
+
+  sub BUILD {
+      my ( $self, $params ) = @_;
+      if ( @{ $self->employees || [] } ) {
+          foreach my $employee ( @{ $self->employees } ) {
+              $employee->employer($self);
+          }
+      }
+  }
+
+  after 'employees' => sub {
+      my ( $self, $employees ) = @_;
+      if ($employees) {
+          foreach my $employee ( @{$employees} ) {
+              $employee->employer($self);
+          }
+      }
+  };
+
+  package Person;
+  use Mouse;
+
+  has 'first_name' => ( is => 'rw', isa => 'Str', required => 1 );
+  has 'last_name'  => ( is => 'rw', isa => 'Str', required => 1 );
+  has 'middle_initial' => (
+      is        => 'rw', isa => 'Str',
+      predicate => 'has_middle_initial'
+  );
+  has 'address' => ( is => 'rw', isa => 'Address' );
+
+  sub full_name {
+      my $self = shift;
+      return $self->first_name
+          . (
+          $self->has_middle_initial
+          ? ' ' . $self->middle_initial . '. '
+          : ' '
+          ) . $self->last_name;
+  }
+
+  package Employee;
+  use Mouse;
+
+  extends 'Person';
+
+  has 'title'    => ( is => 'rw', isa => 'Str',     required => 1 );
+  has 'employer' => ( is => 'rw', isa => 'Company', weak_ref => 1 );
+
+  override 'full_name' => sub {
+      my $self = shift;
+      super() . ', ' . $self->title;
+  };
+}
+
+
+
+# =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';
+}
+
+
+
+
+1;
diff --git a/t/000-recipes/moose_cookbook_basics_recipe5.t b/t/000-recipes/moose_cookbook_basics_recipe5.t
new file mode 100644
index 0000000..8364a38
--- /dev/null
+++ b/t/000-recipes/moose_cookbook_basics_recipe5.t
@@ -0,0 +1,141 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 'no_plan';
+use Test::Exception;
+$| = 1;
+
+
+
+# =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;
+    }
+}
+
+
+
+# =begin testing SETUP
+{
+
+  package Request;
+  use Mouse;
+  use Mouse::Util::TypeConstraints;
+
+  use HTTP::Headers  ();
+  use Params::Coerce ();
+  use URI            ();
+
+  subtype 'My::Types::HTTP::Headers' => as class_type('HTTP::Headers');
+
+  coerce 'My::Types::HTTP::Headers'
+      => from 'ArrayRef'
+          => via { HTTP::Headers->new( @{$_} ) }
+      => from 'HashRef'
+          => via { HTTP::Headers->new( %{$_} ) };
+
+  subtype 'My::Types::URI' => as class_type('URI');
+
+  coerce 'My::Types::URI'
+      => from 'Object'
+          => via { $_->isa('URI')
+                   ? $_
+                   : Params::Coerce::coerce( 'URI', $_ ); }
+      => from 'Str'
+          => via { URI->new( $_, 'http' ) };
+
+  subtype 'Protocol'
+      => as 'Str'
+      => where { /^HTTP\/[0-9]\.[0-9]$/ };
+
+  has 'base' => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 );
+  has 'uri'  => ( is => 'rw', isa => 'My::Types::URI', coerce => 1 );
+  has 'method'   => ( is => 'rw', isa => 'Str' );
+  has 'protocol' => ( is => 'rw', isa => 'Protocol' );
+  has 'headers'  => (
+      is      => 'rw',
+      isa     => 'My::Types::HTTP::Headers',
+      coerce  => 1,
+      default => sub { HTTP::Headers->new }
+  );
+}
+
+
+
+# =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';
+}
+
+{
+    $r->base('http://localhost/');
+    isa_ok( $r->base, 'URI' );
+
+    $r->uri('http://localhost/');
+    isa_ok( $r->uri, 'URI' );
+}
+}
+
+
+
+
+1;
diff --git a/t/000-recipes/moose_cookbook_roles_recipe2.t b/t/000-recipes/moose_cookbook_roles_recipe2.t
new file mode 100644
index 0000000..9fec6dd
--- /dev/null
+++ b/t/000-recipes/moose_cookbook_roles_recipe2.t
@@ -0,0 +1,118 @@
+#!/usr/bin/perl -w
+
+use strict;
+use Test::More 'no_plan';
+use Test::Exception;
+$| = 1;
+
+
+
+# =begin testing SETUP
+{
+
+  package Restartable;
+  use Mouse::Role;
+
+  has 'is_paused' => (
+      is      => 'rw',
+      isa     => 'Bool',
+      default => 0,
+  );
+
+  requires 'save_state', 'load_state';
+
+  sub stop { 1 }
+
+  sub start { 1 }
+
+  package Restartable::ButUnreliable;
+  use Mouse::Role;
+
+  with 'Restartable' => {
+      -alias => {
+          stop  => '_stop',
+          start => '_start'
+      },
+      -excludes => [ 'stop', 'start' ],
+  };
+
+  sub stop {
+      my $self = shift;
+
+      $self->explode() if rand(1) > .5;
+
+      $self->_stop();
+  }
+
+  sub start {
+      my $self = shift;
+
+      $self->explode() if rand(1) > .5;
+
+      $self->_start();
+  }
+
+  package Restartable::ButBroken;
+  use Mouse::Role;
+
+  with 'Restartable' => { -excludes => [ 'stop', 'start' ] };
+
+  sub stop {
+      my $self = shift;
+
+      $self->explode();
+  }
+
+  sub start {
+      my $self = shift;
+
+      $self->explode();
+  }
+}
+
+
+
+# =begin testing
+{
+{
+    my $unreliable = Mouse::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 = Mouse::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' );
+}
+}
+
+
+
+
+1;