From: Tokuhiro Matsuno <tokuhirom@gmail.com>
Date: Tue, 10 Mar 2009 17:05:41 +0000 (+0900)
Subject: make a subtype for each Mouse class This behavior is same as Moose.
X-Git-Tag: 0.20~40
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=gitmo%2FMouse.git;a=commitdiff_plain;h=376973bc604c5f4aff9be7ae9e0d90dc37ee727f

make a subtype for each Mouse class This behavior is same as Moose.
---

diff --git a/lib/Mouse.pm b/lib/Mouse.pm
index 34be993..89b6289 100644
--- a/lib/Mouse.pm
+++ b/lib/Mouse.pm
@@ -115,6 +115,9 @@ sub import {
     $meta->superclasses('Mouse::Object')
         unless $meta->superclasses;
 
+    # make a subtype for each Mouse class
+    class_type($caller) unless find_type_constraint($caller);
+
     no strict 'refs';
     no warnings 'redefine';
     *{$caller.'::meta'} = sub { $meta };
diff --git a/t/000-recipes/basics-recipe10.t b/t/000-recipes/basics-recipe10.t
new file mode 100644
index 0000000..0d6c0a1
--- /dev/null
+++ b/t/000-recipes/basics-recipe10.t
@@ -0,0 +1,228 @@
+#!/usr/bin/perl
+
+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>
+