Commit | Line | Data |
9864f0e4 |
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 | __PACKAGE__->meta->make_immutable(); |
37 | } |
38 | { |
39 | |
40 | package Child; |
41 | use Mouse; |
42 | |
43 | has 'parent' => ( |
44 | is => 'rw', |
45 | isa => 'Parent', |
46 | required => 1, |
47 | trigger => sub { |
48 | my $self = shift; |
49 | |
50 | # if the parent is changed,.. |
51 | # make sure we update |
52 | $self->last_name( $self->parent->last_name ); |
53 | } |
54 | ); |
55 | |
56 | has 'last_name' => ( |
57 | is => 'rw', |
58 | isa => 'Str', |
59 | lazy => 1, |
60 | default => sub { (shift)->parent->last_name } |
61 | ); |
62 | __PACKAGE__->meta->make_immutable(); |
63 | } |
64 | |
65 | my $parent = Parent->new( last_name => 'Smith' ); |
66 | isa_ok( $parent, 'Parent' ); |
67 | |
68 | is( $parent->last_name, 'Smith', |
69 | '... the parent has the last name we expected' ); |
70 | |
71 | $parent->children( [ map { Child->new( parent => $parent ) } ( 0 .. 3 ) ] ); |
72 | |
73 | foreach my $child ( @{ $parent->children } ) { |
74 | is( $child->last_name, $parent->last_name, |
75 | '... parent and child have the same last name (' |
76 | . $parent->last_name |
77 | . ')' ); |
78 | } |
79 | |
80 | $parent->last_name('Jones'); |
81 | is( $parent->last_name, 'Jones', '... the parent has the new last name' ); |
82 | |
83 | foreach my $child ( @{ $parent->children } ) { |
84 | is( $child->last_name, $parent->last_name, |
85 | '... parent and child have the same last name (' |
86 | . $parent->last_name |
87 | . ')' ); |
88 | } |
89 | |
90 | # make a new parent |
91 | |
92 | my $parent2 = Parent->new( last_name => 'Brown' ); |
93 | isa_ok( $parent2, 'Parent' ); |
94 | |
95 | # orphan the child |
96 | |
97 | my $orphan = pop @{ $parent->children }; |
98 | |
99 | # and then the new parent adopts it |
100 | |
101 | $orphan->parent($parent2); |
102 | |
103 | foreach my $child ( @{ $parent->children } ) { |
104 | is( $child->last_name, $parent->last_name, |
105 | '... parent and child have the same last name (' |
106 | . $parent->last_name |
107 | . ')' ); |
108 | } |
109 | |
110 | isnt( $orphan->last_name, $parent->last_name, |
111 | '... the orphan child does not have the same last name anymore (' |
112 | . $parent2->last_name |
113 | . ')' ); |
114 | is( $orphan->last_name, $parent2->last_name, |
115 | '... parent2 and orphan child have the same last name (' |
116 | . $parent2->last_name |
117 | . ')' ); |
118 | |
119 | # make sure that changes still will not propagate |
120 | |
121 | $parent->last_name('Miller'); |
122 | is( $parent->last_name, 'Miller', |
123 | '... the parent has the new last name (again)' ); |
124 | |
125 | foreach my $child ( @{ $parent->children } ) { |
126 | is( $child->last_name, $parent->last_name, |
127 | '... parent and child have the same last name (' |
128 | . $parent->last_name |
129 | . ')' ); |
130 | } |
131 | |
132 | isnt( $orphan->last_name, $parent->last_name, |
133 | '... the orphan child is not affected by changes in the parent anymore' ); |
134 | is( $orphan->last_name, $parent2->last_name, |
135 | '... parent2 and orphan child have the same last name (' |
136 | . $parent2->last_name |
137 | . ')' ); |