Rename t/000-recipes to t/000_recipes

[gitmo/Mouse.git] / t / 000-recipes / basics-recipe10.t

diff --git a/t/000-recipes/basics-recipe10.t b/t/000-recipes/basics-recipe10.t
deleted file mode 100644 (file)
index 530ff0b..0000000
--- a/t/000-recipes/basics-recipe10.t
+++ /dev/null
@@ -1,230 +0,0 @@
-#!/usr/bin/perl
-
-# This test is taken from Moose :)
-
-use strict;
-use warnings;
-
-use Test::More tests => 10;
-
-
-{
-    package Human;
-
-    use Mouse;
-    use Mouse::Util::TypeConstraints;
-
-    subtype 'Gender'
-        => as 'Str'
-        => where { $_ =~ m{^[mf]$}s };
-
-    has 'gender' => ( is => 'ro', isa => 'Gender', required => 1 );
-
-    has 'mother' => ( is => 'ro', isa => 'Human' );
-    has 'father' => ( is => 'ro', isa => 'Human' );
-
-    use overload '+' => \&_overload_add, fallback => 1;
-
-    sub _overload_add {
-        my ( $one, $two ) = @_;
-
-        die('Only male and female humans may create children')
-            if ( $one->gender() eq $two->gender() );
-
-        my ( $mother, $father )
-            = ( $one->gender eq 'f' ? ( $one, $two ) : ( $two, $one ) );
-
-        my $gender = 'f';
-        $gender = 'm' if ( rand() >= 0.5 );
-
-        return Human->new(
-            gender    => $gender,
-            eye_color => ( $one->eye_color() + $two->eye_color() ),
-            mother    => $mother,
-            father    => $father,
-        );
-    }
-
-    # use List::MoreUtils 'zip'
-    # code taken from List::MoreUtils
-    sub zip (\@\@;\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@\@) {
-        my $max = -1;
-        $max < $#$_ && ( $max = $#$_ ) for @_;
-
-        map { my $ix = $_; map $_->[$ix], @_; } 0 .. $max;
-    }
-
-
-    coerce 'Human::EyeColor'
-        => from 'ArrayRef'
-        => via { my @genes = qw( bey2_1 bey2_2 gey_1 gey_2 );
-                 return Human::EyeColor->new( zip( @genes, @{$_} ) ); };
-
-    has 'eye_color' => (
-        is       => 'ro',
-        isa      => 'Human::EyeColor',
-        coerce   => 1,
-        required => 1,
-    );
-
-}
-
-{
-    package Human::Gene::bey2;
-
-    use Mouse;
-    use Mouse::Util::TypeConstraints;
-
-    type 'bey2_color' => where { $_ =~ m{^(?:brown|blue)$} };
-
-    has 'color' => ( is => 'ro', isa => 'bey2_color' );
-}
-
-{
-    package Human::Gene::gey;
-
-    use Mouse;
-    use Mouse::Util::TypeConstraints;
-
-    type 'gey_color' => where { $_ =~ m{^(?:green|blue)$} };
-
-    has 'color' => ( is => 'ro', isa => 'gey_color' );
-}
-
-{
-    package Human::EyeColor;
-
-    use Mouse;
-    use Mouse::Util::TypeConstraints;
-
-    coerce 'Human::Gene::bey2'
-        => from 'Str'
-            => via { Human::Gene::bey2->new( color => $_ ) };
-
-    coerce 'Human::Gene::gey'
-        => from 'Str'
-            => via { Human::Gene::gey->new( color => $_ ) };
-
-    has [qw( bey2_1 bey2_2 )] =>
-        ( is => 'ro', isa => 'Human::Gene::bey2', coerce => 1 );
-
-    has [qw( gey_1 gey_2 )] =>
-        ( is => 'ro', isa => 'Human::Gene::gey', coerce => 1 );
-
-    sub color {
-        my ($self) = @_;
-
-        return 'brown'
-            if ( $self->bey2_1->color() eq 'brown'
-            or $self->bey2_2->color() eq 'brown' );
-
-        return 'green'
-            if ( $self->gey_1->color() eq 'green'
-            or $self->gey_2->color() eq 'green' );
-
-        return 'blue';
-    }
-
-    use overload '""' => \&color, fallback => 1;
-
-    use overload '+' => \&_overload_add, fallback => 1;
-
-    sub _overload_add {
-        my ( $one, $two ) = @_;
-
-        my $one_bey2 = 'bey2_' . _rand2();
-        my $two_bey2 = 'bey2_' . _rand2();
-
-        my $one_gey = 'gey_' . _rand2();
-        my $two_gey = 'gey_' . _rand2();
-
-        return Human::EyeColor->new(
-            bey2_1 => $one->$one_bey2->color(),
-            bey2_2 => $two->$two_bey2->color(),
-            gey_1  => $one->$one_gey->color(),
-            gey_2  => $two->$two_gey->color(),
-        );
-    }
-
-    sub _rand2 {
-        return 1 + int( rand(2) );
-    }
-}
-
-my $gene_color_sets = [
-    [ qw( blue blue blue blue )     => 'blue' ],
-    [ qw( blue blue green blue )    => 'green' ],
-    [ qw( blue blue blue green )    => 'green' ],
-    [ qw( blue blue green green )   => 'green' ],
-    [ qw( brown blue blue blue )    => 'brown' ],
-    [ qw( brown brown green green ) => 'brown' ],
-    [ qw( blue brown green blue )   => 'brown' ],
-];
-
-foreach my $set (@$gene_color_sets) {
-    my $expected_color = pop(@$set);
-
-    my $person = Human->new(
-        gender    => 'f',
-        eye_color => $set,
-    );
-
-    is(
-        $person->eye_color(),
-        $expected_color,
-        'gene combination '
-            . join( ',', @$set )
-            . ' produces '
-            . $expected_color
-            . ' eye color',
-    );
-}
-
-my $parent_sets = [
-    [
-        [qw( blue blue blue blue )],
-        [qw( blue blue blue blue )] => 'blue'
-    ],
-    [
-        [qw( blue blue blue blue )],
-        [qw( brown brown green blue )] => 'brown'
-    ],
-    [
-        [qw( blue blue green green )],
-        [qw( blue blue green green )] => 'green'
-    ],
-];
-
-foreach my $set (@$parent_sets) {
-    my $expected_color = pop(@$set);
-
-    my $mother         = Human->new(
-        gender    => 'f',
-        eye_color => shift(@$set),
-    );
-
-    my $father = Human->new(
-        gender    => 'm',
-        eye_color => shift(@$set),
-    );
-
-    my $child = $mother + $father;
-
-    is(
-        $child->eye_color(),
-        $expected_color,
-        'mother '
-            . $mother->eye_color()
-            . ' + father '
-            . $father->eye_color()
-            . ' = child '
-            . $expected_color,
-    );
-}
-
-# Hmm, not sure how to test for random selection of genes since
-# I could theoretically run an infinite number of iterations and
-# never find proof that a child has inherited a particular gene.
-
-# AUTHOR: Aran Clary Deltac <bluefeet@cpan.org>
-