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     package Parent;
  17     use Moose;
  18
  19     has 'last_name' => (
  20         is      => 'rw',
  21         isa     => 'Str',
  22         trigger => sub {
  23             my $self = shift;
  24             # if the parents last-name changes
  25             # then so do all the childrens
  26             foreach my $child (@{$self->children}) {
  27                 $child->last_name($self->last_name);
  28             }
  29         }
  30     );
  31
  32     has 'children' => (is => 'rw', isa => 'ArrayRef', default => sub {[]});
  33 }
  34 {
  35     package Child;
  36     use Moose;
  37
  38     has 'parent' => (
  39         is          => 'rw',
  40         isa         => 'Parent',
  41         required    => 1,
  42         trigger     => sub {
  43             my $self = shift;
  44             # if the parent is changed,..
  45             # make sure we update
  46             $self->last_name($self->parent->last_name);
  47         }
  48     );
  49
  50     has 'last_name' => (
  51         is      => 'rw',
  52         isa     => 'Str',
  53         lazy    => 1,
  54         default => sub { (shift)->parent->last_name }
  55     );
  56
  57 }
  58
  59 my $parent = Parent->new(last_name => 'Smith');
  60 isa_ok($parent, 'Parent');
  61
  62 is($parent->last_name, 'Smith', '... the parent has the last name we expected');
  63
  64 $parent->children([
  65     map { Child->new(parent => $parent) } (0 .. 3)
  66 ]);
  67
  68 foreach my $child (@{$parent->children}) {
  69     is($child->last_name, $parent->last_name, '... parent and child have the same last name (' . $parent->last_name . ')');
  70 }
  71
  72 $parent->last_name('Jones');
  73 is($parent->last_name, 'Jones', '... the parent has the new last name');
  74
  75 foreach my $child (@{$parent->children}) {
  76     is($child->last_name, $parent->last_name, '... parent and child have the same last name (' . $parent->last_name . ')');
  77 }
  78
  79 # make a new parent
  80
  81 my $parent2 = Parent->new(last_name => 'Brown');
  82 isa_ok($parent2, 'Parent');
  83
  84 # orphan the child
  85
  86 my $orphan = pop @{$parent->children};
  87
  88 # and then the new parent adopts it
  89
  90 $orphan->parent($parent2);
  91
  92 foreach my $child (@{$parent->children}) {
  93     is($child->last_name, $parent->last_name, '... parent and child have the same last name (' . $parent->last_name . ')');
  94 }
  95
  96 isnt($orphan->last_name, $parent->last_name, '... the orphan child does not have the same last name anymore (' . $parent2->last_name . ')');
  97 is($orphan->last_name, $parent2->last_name, '... parent2 and orphan child have the same last name (' . $parent2->last_name . ')');
  98
  99 # make sure that changes still will not propagate
 100
 101 $parent->last_name('Miller');
 102 is($parent->last_name, 'Miller', '... the parent has the new last name (again)');
 103
 104 foreach my $child (@{$parent->children}) {
 105     is($child->last_name, $parent->last_name, '... parent and child have the same last name (' . $parent->last_name . ')');
 106 }
 107
 108 isnt($orphan->last_name, $parent->last_name, '... the orphan child is not affected by changes in the parent anymore');
 109 is($orphan->last_name, $parent2->last_name, '... parent2 and orphan child have the same last name (' . $parent2->last_name . ')');