Fix docs. The phrases "Fewer than 1%" and "over 96%" are very confusing, so I removed...

[gitmo/Mouse.git] / t / 200_examples / 0071_Child_Parent_attr_inherit_imm.t

#!/usr/bin/perl

use strict;
use warnings;

use Test::More tests => 23;

=pod

Some examples of triggers and how they can
be used to manage parent-child relationships.

=cut

{

    package Parent;
    use Mouse;

    has 'last_name' => (
        is      => 'rw',
        isa     => 'Str',
        trigger => sub {
            my $self = shift;

            # if the parents last-name changes
            # then so do all the childrens
            foreach my $child ( @{ $self->children } ) {
                $child->last_name( $self->last_name );
            }
        }
    );

    has 'children' =>
        ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );
    __PACKAGE__->meta->make_immutable();
}
{

    package Child;
    use Mouse;

    has 'parent' => (
        is       => 'rw',
        isa      => 'Parent',
        required => 1,
        trigger  => sub {
            my $self = shift;

            # if the parent is changed,..
            # make sure we update
            $self->last_name( $self->parent->last_name );
        }
    );

    has 'last_name' => (
        is      => 'rw',
        isa     => 'Str',
        lazy    => 1,
        default => sub { (shift)->parent->last_name }
    );
    __PACKAGE__->meta->make_immutable();
}

my $parent = Parent->new( last_name => 'Smith' );
isa_ok( $parent, 'Parent' );

is( $parent->last_name, 'Smith',
    '... the parent has the last name we expected' );

$parent->children( [ map { Child->new( parent => $parent ) } ( 0 .. 3 ) ] );

foreach my $child ( @{ $parent->children } ) {
    is( $child->last_name, $parent->last_name,
              '... parent and child have the same last name ('
            . $parent->last_name
            . ')' );
}

$parent->last_name('Jones');
is( $parent->last_name, 'Jones', '... the parent has the new last name' );

foreach my $child ( @{ $parent->children } ) {
    is( $child->last_name, $parent->last_name,
              '... parent and child have the same last name ('
            . $parent->last_name
            . ')' );
}

# make a new parent

my $parent2 = Parent->new( last_name => 'Brown' );
isa_ok( $parent2, 'Parent' );

# orphan the child

my $orphan = pop @{ $parent->children };

# and then the new parent adopts it

$orphan->parent($parent2);

foreach my $child ( @{ $parent->children } ) {
    is( $child->last_name, $parent->last_name,
              '... parent and child have the same last name ('
            . $parent->last_name
            . ')' );
}

isnt( $orphan->last_name, $parent->last_name,
          '... the orphan child does not have the same last name anymore ('
        . $parent2->last_name
        . ')' );
is( $orphan->last_name, $parent2->last_name,
          '... parent2 and orphan child have the same last name ('
        . $parent2->last_name
        . ')' );

# make sure that changes still will not propagate

$parent->last_name('Miller');
is( $parent->last_name, 'Miller',
    '... the parent has the new last name (again)' );

foreach my $child ( @{ $parent->children } ) {
    is( $child->last_name, $parent->last_name,
              '... parent and child have the same last name ('
            . $parent->last_name
            . ')' );
}

isnt( $orphan->last_name, $parent->last_name,
    '... the orphan child is not affected by changes in the parent anymore' );
is( $orphan->last_name, $parent2->last_name,
          '... parent2 and orphan child have the same last name ('
        . $parent2->last_name
        . ')' );