Commit | Line | Data |
7a50b450 |
1 | #!/usr/bin/perl |
fde8e43f |
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; |
7a50b450 |
5 | |
6 | use strict; |
7 | use warnings; |
8 | |
fde8e43f |
9 | use Test::More; |
7a50b450 |
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 | . ')' ); |
fde8e43f |
140 | |
141 | done_testing; |