Commit | Line | Data |
af3c1f96 |
1 | #!/usr/bin/perl |
2 | |
3 | use strict; |
4 | use warnings; |
5 | |
a28e50e4 |
6 | use Test::More; |
b10dde3a |
7 | use Test::Fatal; |
b57ec19f |
8 | use Test::Moose qw(with_immutable); |
af3c1f96 |
9 | use Scalar::Util 'blessed'; |
10 | |
7ff56534 |
11 | use Moose::Util::TypeConstraints; |
af3c1f96 |
12 | |
13 | subtype 'Positive' |
14 | => as 'Num' |
15 | => where { $_ > 0 }; |
16 | |
17 | { |
18 | package Parent; |
19 | use Moose; |
20 | |
21 | has name => ( |
22 | is => 'rw', |
23 | isa => 'Str', |
24 | ); |
25 | |
26 | has lazy_classname => ( |
27 | is => 'ro', |
28 | lazy => 1, |
29 | default => sub { "Parent" }, |
30 | ); |
31 | |
32 | has type_constrained => ( |
33 | is => 'rw', |
34 | isa => 'Num', |
35 | default => 5.5, |
36 | ); |
37 | |
38 | package Child; |
39 | use Moose; |
40 | extends 'Parent'; |
41 | |
42 | has '+name' => ( |
43 | default => 'Junior', |
44 | ); |
45 | |
46 | has '+lazy_classname' => ( |
b4679f81 |
47 | default => sub {"Child"}, |
af3c1f96 |
48 | ); |
49 | |
50 | has '+type_constrained' => ( |
51 | isa => 'Int', |
52 | default => 100, |
53 | ); |
9dfb20ff |
54 | |
55 | our %trigger_calls; |
56 | our %initializer_calls; |
57 | |
58 | has new_attr => ( |
b4679f81 |
59 | is => 'rw', |
60 | isa => 'Str', |
9dfb20ff |
61 | trigger => sub { |
b4679f81 |
62 | my ( $self, $val, $attr ) = @_; |
9dfb20ff |
63 | $trigger_calls{new_attr}++; |
64 | }, |
65 | initializer => sub { |
b4679f81 |
66 | my ( $self, $value, $set, $attr ) = @_; |
9dfb20ff |
67 | $initializer_calls{new_attr}++; |
8005c51c |
68 | $set->($value); |
9dfb20ff |
69 | }, |
70 | ); |
af3c1f96 |
71 | } |
72 | |
b57ec19f |
73 | my @classes = qw(Parent Child); |
af3c1f96 |
74 | |
b4679f81 |
75 | with_immutable { |
b57ec19f |
76 | my $foo = Parent->new; |
77 | my $bar = Parent->new; |
78 | |
b4679f81 |
79 | is( blessed($foo), 'Parent', 'Parent->new gives a Parent object' ); |
80 | is( $foo->name, undef, 'No name yet' ); |
81 | is( $foo->lazy_classname, 'Parent', "lazy attribute initialized" ); |
82 | is( |
83 | exception { $foo->type_constrained(10.5) }, undef, |
84 | "Num type constraint for now.." |
85 | ); |
af3c1f96 |
86 | |
b57ec19f |
87 | # try to rebless, except it will fail due to Child's stricter type constraint |
b4679f81 |
88 | like( |
89 | exception { Child->meta->rebless_instance($foo) }, |
90 | qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, |
91 | '... this failed because of type check' |
92 | ); |
93 | like( |
94 | exception { Child->meta->rebless_instance($bar) }, |
95 | qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 5\.5/, |
96 | '... this failed because of type check' |
97 | ); |
af3c1f96 |
98 | |
b57ec19f |
99 | $foo->type_constrained(10); |
100 | $bar->type_constrained(5); |
af3c1f96 |
101 | |
b57ec19f |
102 | Child->meta->rebless_instance($foo); |
b4679f81 |
103 | Child->meta->rebless_instance( $bar, new_attr => 'blah' ); |
af3c1f96 |
104 | |
b4679f81 |
105 | is( blessed($foo), 'Child', 'successfully reblessed into Child' ); |
106 | is( $foo->name, 'Junior', "Child->name's default came through" ); |
af3c1f96 |
107 | |
b4679f81 |
108 | is( |
109 | $foo->lazy_classname, 'Parent', |
110 | "lazy attribute was already initialized" |
111 | ); |
112 | is( |
113 | $bar->lazy_classname, 'Child', |
114 | "lazy attribute just now initialized" |
115 | ); |
b57ec19f |
116 | |
b4679f81 |
117 | like( |
118 | exception { $foo->type_constrained(10.5) }, |
119 | qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, |
120 | '... this failed because of type check' |
121 | ); |
9dfb20ff |
122 | |
b4679f81 |
123 | is_deeply( |
124 | \%Child::trigger_calls, { new_attr => 1 }, |
125 | 'Trigger fired on rebless_instance' |
126 | ); |
127 | is_deeply( |
128 | \%Child::initializer_calls, { new_attr => 1 }, |
129 | 'Initializer fired on rebless_instance' |
130 | ); |
9dfb20ff |
131 | |
132 | undef %Child::trigger_calls; |
133 | undef %Child::initializer_calls; |
134 | |
b57ec19f |
135 | } |
136 | @classes; |
a28e50e4 |
137 | |
138 | done_testing; |