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