t/200_examples/007_Child_Parent_attr_inherit.t

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