Commit | Line | Data |
7a50b450 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
9864f0e4 |
6 | use Test::More tests => 23; |
7a50b450 |
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 | . ')' ); |