t/200_examples/007_Child_Parent_attr_inherit.t

   1 #!/usr/bin/perl
   2
   3 use strict;
   4 use warnings;
   5
   6 use Test::More tests => 23;
   7
   8 =pod
   9
  10 Some examples of triggers and how they can
  11 be used to manage parent-child relationships.
  12
  13 =cut
  14
  15 {
  16
  17     package Parent;
  18     use Mouse;
  19
  20     has 'last_name' => (
  21         is      => 'rw',
  22         isa     => 'Str',
  23         trigger => sub {
  24             my $self = shift;
  25
  26             # if the parents last-name changes
  27             # then so do all the childrens
  28             foreach my $child ( @{ $self->children } ) {
  29                 $child->last_name( $self->last_name );
  30             }
  31         }
  32     );
  33
  34     has 'children' =>
  35         ( is => 'rw', isa => 'ArrayRef', default => sub { [] } );
  36 }
  37 {
  38
  39     package Child;
  40     use Mouse;
  41
  42     has 'parent' => (
  43         is       => 'rw',
  44         isa      => 'Parent',
  45         required => 1,
  46         trigger  => sub {
  47             my $self = shift;
  48
  49             # if the parent is changed,..
  50             # make sure we update
  51             $self->last_name( $self->parent->last_name );
  52         }
  53     );
  54
  55     has 'last_name' => (
  56         is      => 'rw',
  57         isa     => 'Str',
  58         lazy    => 1,
  59         default => sub { (shift)->parent->last_name }
  60     );
  61
  62 }
  63
  64 my $parent = Parent->new( last_name => 'Smith' );
  65 isa_ok( $parent, 'Parent' );
  66
  67 is( $parent->last_name, 'Smith',
  68     '... the parent has the last name we expected' );
  69
  70 $parent->children( [ map { Child->new( parent => $parent ) } ( 0 .. 3 ) ] );
  71
  72 foreach my $child ( @{ $parent->children } ) {
  73     is( $child->last_name, $parent->last_name,
  74               '... parent and child have the same last name ('
  75             . $parent->last_name
  76             . ')' );
  77 }
  78
  79 $parent->last_name('Jones');
  80 is( $parent->last_name, 'Jones', '... the parent has the new last name' );
  81
  82 foreach my $child ( @{ $parent->children } ) {
  83     is( $child->last_name, $parent->last_name,
  84               '... parent and child have the same last name ('
  85             . $parent->last_name
  86             . ')' );
  87 }
  88
  89 # make a new parent
  90
  91 my $parent2 = Parent->new( last_name => 'Brown' );
  92 isa_ok( $parent2, 'Parent' );
  93
  94 # orphan the child
  95
  96 my $orphan = pop @{ $parent->children };
  97
  98 # and then the new parent adopts it
  99
 100 $orphan->parent($parent2);
 101
 102 foreach my $child ( @{ $parent->children } ) {
 103     is( $child->last_name, $parent->last_name,
 104               '... parent and child have the same last name ('
 105             . $parent->last_name
 106             . ')' );
 107 }
 108
 109 isnt( $orphan->last_name, $parent->last_name,
 110           '... the orphan child does not have the same last name anymore ('
 111         . $parent2->last_name
 112         . ')' );
 113 is( $orphan->last_name, $parent2->last_name,
 114           '... parent2 and orphan child have the same last name ('
 115         . $parent2->last_name
 116         . ')' );
 117
 118 # make sure that changes still will not propagate
 119
 120 $parent->last_name('Miller');
 121 is( $parent->last_name, 'Miller',
 122     '... the parent has the new last name (again)' );
 123
 124 foreach my $child ( @{ $parent->children } ) {
 125     is( $child->last_name, $parent->last_name,
 126               '... parent and child have the same last name ('
 127             . $parent->last_name
 128             . ')' );
 129 }
 130
 131 isnt( $orphan->last_name, $parent->last_name,
 132     '... the orphan child is not affected by changes in the parent anymore' );
 133 is( $orphan->last_name, $parent2->last_name,
 134           '... parent2 and orphan child have the same last name ('
 135         . $parent2->last_name
 136         . ')' );