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' => ( |
47 | default => sub { "Child" }, |
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 => ( |
59 | is => 'rw', isa => 'Str', |
60 | trigger => sub { |
61 | my ($self, $val, $attr) = @_; |
62 | $trigger_calls{new_attr}++; |
63 | }, |
64 | initializer => sub { |
65 | my ($self, $value, $set, $attr) = @_; |
66 | $initializer_calls{new_attr}++; |
67 | }, |
68 | ); |
af3c1f96 |
69 | } |
70 | |
b57ec19f |
71 | my @classes = qw(Parent Child); |
af3c1f96 |
72 | |
b57ec19f |
73 | with_immutable |
74 | { |
75 | my $foo = Parent->new; |
76 | my $bar = Parent->new; |
77 | |
78 | is(blessed($foo), 'Parent', 'Parent->new gives a Parent object'); |
79 | is($foo->name, undef, 'No name yet'); |
80 | is($foo->lazy_classname, 'Parent', "lazy attribute initialized"); |
81 | is( exception { $foo->type_constrained(10.5) }, undef, "Num type constraint for now.." ); |
af3c1f96 |
82 | |
b57ec19f |
83 | # try to rebless, except it will fail due to Child's stricter type constraint |
84 | like( exception { Child->meta->rebless_instance($foo) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, '... this failed because of type check' ); |
85 | like( exception { Child->meta->rebless_instance($bar) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 5\.5/, '... this failed because of type check' ); |
af3c1f96 |
86 | |
b57ec19f |
87 | $foo->type_constrained(10); |
88 | $bar->type_constrained(5); |
af3c1f96 |
89 | |
b57ec19f |
90 | Child->meta->rebless_instance($foo); |
9dfb20ff |
91 | Child->meta->rebless_instance($bar, new_attr => 'blah'); |
af3c1f96 |
92 | |
b57ec19f |
93 | is(blessed($foo), 'Child', 'successfully reblessed into Child'); |
94 | is($foo->name, 'Junior', "Child->name's default came through"); |
af3c1f96 |
95 | |
b57ec19f |
96 | is($foo->lazy_classname, 'Parent', "lazy attribute was already initialized"); |
97 | is($bar->lazy_classname, 'Child', "lazy attribute just now initialized"); |
af3c1f96 |
98 | |
b57ec19f |
99 | like( exception { $foo->type_constrained(10.5) }, qr/^Attribute \(type_constrained\) does not pass the type constraint because\: Validation failed for 'Int' with value 10\.5/, '... this failed because of type check' ); |
100 | |
9dfb20ff |
101 | |
102 | TODO: { |
103 | local $TODO = 'Moose::Meta::Class does not yet call triggers for rebless_instance!'; |
104 | is_deeply(\%Child::trigger_calls, { new_attr => 1 }, 'Trigger fired on rebless_instance'); |
105 | } |
106 | is_deeply(\%Child::initializer_calls, { new_attr => 1 }, 'Initializer fired on rebless_instance'); |
107 | |
108 | undef %Child::trigger_calls; |
109 | undef %Child::initializer_calls; |
110 | |
b57ec19f |
111 | } |
112 | @classes; |
a28e50e4 |
113 | |
114 | done_testing; |